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"
64 #include <ent/ent-float.h>
65 #include <ent/ent-mpfr.h>
67 #ifdef DOUG_LEA_MALLOC
75 #define SXE_DEBUG_GC_GMP(args...) SXE_DEBUG_GC("[gmp]: " args)
78 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
81 # if defined HAVE_GC_GC_H
83 # elif defined HAVE_GC_H
86 /* declare the 3 funs we need */
87 extern void *GC_malloc(size_t);
88 extern void *GC_malloc_atomic(size_t);
89 extern void *GC_malloc_uncollectable(size_t);
90 extern void *GC_malloc_stubborn(size_t);
91 extern void *GC_realloc(void*, size_t);
92 extern char *GC_strdup(const char*);
93 extern void GC_free(void*);
95 # error "I'm very concerned about your BDWGC support"
99 /* category subsystem */
100 #include "category.h"
105 EXFUN(Fgarbage_collect, 0);
108 /* this is _way_ too slow to be part of the standard debug options */
109 #if defined(DEBUG_SXEMACS) && defined(MULE)
110 #define VERIFY_STRING_CHARS_INTEGRITY
114 /* Define this to use malloc/free with no freelist for all datatypes,
115 the hope being that some debugging tools may help detect
116 freed memory references */
117 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
119 #define ALLOC_NO_POOLS
123 static Fixnum debug_allocation;
124 static Fixnum debug_allocation_backtrace_length;
127 #if defined EF_USE_ASYNEQ && !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
128 #include "semaphore.h"
129 sxe_mutex_t cons_mutex;
130 #endif /* EF_USE_ASYNEQ && !BDWGC */
132 #include "events/event-queue.h"
133 #include "events/workers.h"
134 dllist_t workers = NULL;
137 /* Number of bytes of consing done since the last gc */
138 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
139 #define INCREMENT_CONS_COUNTER_1(size)
143 EMACS_INT consing_since_gc;
144 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
149 debug_allocation_backtrace(void)
151 if (debug_allocation_backtrace_length > 0) {
152 debug_short_backtrace (debug_allocation_backtrace_length);
157 #define INCREMENT_CONS_COUNTER(foosize, type) \
159 if (debug_allocation) { \
160 stderr_out("allocating %s (size %ld)\n", \
161 type, (long)foosize); \
162 debug_allocation_backtrace (); \
164 INCREMENT_CONS_COUNTER_1(foosize); \
166 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
168 if (debug_allocation > 1) { \
169 stderr_out("allocating noseeum %s (size %ld)\n", \
170 type, (long)foosize); \
171 debug_allocation_backtrace (); \
173 INCREMENT_CONS_COUNTER_1(foosize); \
176 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
177 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
178 INCREMENT_CONS_COUNTER_1 (size)
182 DECREMENT_CONS_COUNTER(size_t size)
183 __attribute__((always_inline));
186 DECREMENT_CONS_COUNTER(size_t size)
188 consing_since_gc -= (size);
189 if (consing_since_gc < 0) {
190 consing_since_gc = 0;
194 /* Number of bytes of consing since gc before another gc should be done. */
195 EMACS_INT gc_cons_threshold;
197 /* Nonzero during gc */
200 /* Number of times GC has happened at this level or below.
201 * Level 0 is most volatile, contrary to usual convention.
202 * (Of course, there's only one level at present) */
203 EMACS_INT gc_generation_number[1];
205 /* This is just for use by the printer, to allow things to print uniquely */
206 static int lrecord_uid_counter;
208 /* Nonzero when calling certain hooks or doing other things where
210 int gc_currently_forbidden;
213 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
214 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
216 /* "Garbage collecting" */
217 Lisp_Object Vgc_message;
218 Lisp_Object Vgc_pointer_glyph;
219 static char gc_default_message[] = "Garbage collecting";
220 Lisp_Object Qgarbage_collecting;
222 /* Non-zero means we're in the process of doing the dump */
225 #ifdef ERROR_CHECK_TYPECHECK
227 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
231 int c_readonly(Lisp_Object obj)
233 return POINTER_TYPE_P(XTYPE(obj)) && C_READONLY(obj);
236 int lisp_readonly(Lisp_Object obj)
238 return POINTER_TYPE_P(XTYPE(obj)) && LISP_READONLY(obj);
241 /* Maximum amount of C stack to save when a GC happens. */
243 #ifndef MAX_SAVE_STACK
244 #define MAX_SAVE_STACK 0 /* 16000 */
247 /* Non-zero means ignore malloc warnings. Set during initialization. */
248 int ignore_malloc_warnings;
250 static void *breathing_space = NULL;
252 void release_breathing_space(void)
254 if (breathing_space) {
255 void *tmp = breathing_space;
256 breathing_space = NULL;
261 /* malloc calls this if it finds we are near exhausting storage */
262 void malloc_warning(const char *str)
264 if (ignore_malloc_warnings)
270 "Killing some buffers may delay running out of memory.\n"
271 "However, certainly by the time you receive the 95%% warning,\n"
272 "you should clean up, kill this Emacs, and start a new one.", str);
275 /* Called if malloc returns zero */
276 DOESNT_RETURN memory_full(void)
278 /* Force a GC next time eval is called.
279 It's better to loop garbage-collecting (we might reclaim enough
280 to win) than to loop beeping and barfing "Memory exhausted"
282 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
283 /* that's all we can do */
286 consing_since_gc = gc_cons_threshold + 1;
287 release_breathing_space();
290 /* Flush some histories which might conceivably contain garbalogical
292 if (!NILP(Fboundp(Qvalues))) {
295 Vcommand_history = Qnil;
297 error("Memory exhausted");
300 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
301 /* like malloc and realloc but check for no memory left, and block input. */
304 void *xmalloc(size_t size)
306 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
307 /* yes i know this is contradicting because of the outer conditional
308 * but this here and the definition in lisp.h are meant to be
310 void *val = zmalloc(size);
311 #else /* !HAVE_BDWGC */
312 void *val = ymalloc(size);
313 #endif /* HAVE_BDWGC */
315 if (!val && (size != 0))
320 #undef xmalloc_atomic
321 void *xmalloc_atomic(size_t size)
323 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
324 void *val = zmalloc_atomic(size);
325 #else /* !HAVE_BDWGC */
326 void *val = ymalloc_atomic(size);
327 #endif /* HAVE_BDWGC */
329 if (!val && (size != 0))
335 static void *xcalloc(size_t nelem, size_t elsize)
337 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
338 void *val = zcalloc(nelem, elsize);
340 void *val = ycalloc(nelem, elsize);
343 if (!val && (nelem != 0))
348 void *xmalloc_and_zero(size_t size)
350 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
351 return zmalloc_and_zero(size);
353 return xcalloc(size, 1);
358 void *xrealloc(void *block, size_t size)
360 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
361 void *val = zrealloc(block, size);
362 #else /* !HAVE_BDWGC */
363 /* We must call malloc explicitly when BLOCK is 0, since some
364 reallocs don't do this. */
365 void *val = block ? yrealloc(block, size) : ymalloc(size);
366 #endif /* HAVE_BDWGC */
368 if (!val && (size != 0))
374 #ifdef ERROR_CHECK_GC
377 typedef unsigned int four_byte_t;
378 #elif SIZEOF_LONG == 4
379 typedef unsigned long four_byte_t;
380 #elif SIZEOF_SHORT == 4
381 typedef unsigned short four_byte_t;
383 What kind of strange - ass system are we running on ?
385 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
386 static void deadbeef_memory(void *ptr, size_t size)
388 four_byte_t *ptr4 = (four_byte_t *) ptr;
389 size_t beefs = size >> 2;
391 /* In practice, size will always be a multiple of four. */
393 (*ptr4++) = 0xDEADBEEF;
397 #else /* !ERROR_CHECK_GC */
399 #define deadbeef_memory(ptr, size)
401 #endif /* !ERROR_CHECK_GC */
404 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
405 char *xstrdup(const char *str)
407 #ifdef ERROR_CHECK_MALLOC
408 #if SIZEOF_VOID_P == 4
409 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
410 error until much later on for many system mallocs, such as
411 the one that comes with Solaris 2.3. FMH!! */
412 assert(str != (void *)0xDEADBEEF);
413 #elif SIZEOF_VOID_P == 8
414 assert(str != (void*)0xCAFEBABEDEADBEEF);
416 #endif /* ERROR_CHECK_MALLOC */
418 int len = strlen(str)+1; /* for stupid terminating 0 */
420 void *val = xmalloc(len);
423 return (char*)memcpy(val, str, len);
429 #if !defined HAVE_STRDUP
430 /* will be a problem I think */
431 char *strdup(const char *s)
435 #endif /* !HAVE_STRDUP */
439 allocate_lisp_storage(size_t size)
441 return xmalloc(size);
444 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
446 lcrec_register_finaliser(struct lcrecord_header *b)
448 GC_finalization_proc *foo = NULL;
450 auto void lcrec_finaliser();
452 auto void lcrec_finaliser(void *obj, void *SXE_UNUSED(data))
454 const struct lrecord_implementation *lrimp =
455 XRECORD_LHEADER_IMPLEMENTATION(obj);
456 if (LIKELY(lrimp->finalizer != NULL)) {
457 SXE_DEBUG_GC("running the finaliser on %p :type %d\n",
459 lrimp->finalizer(obj, 0);
462 memset(obj, 0, sizeof(struct lcrecord_header));
466 SXE_DEBUG_GC("lcrec-fina %p\n", b);
467 GC_REGISTER_FINALIZER(b, lcrec_finaliser, NULL, foo, bar);
472 lcrec_register_finaliser(struct lcrecord_header *SXE_UNUSED(b))
476 #endif /* HAVE_BDWGC */
478 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
479 /* lcrecords are chained together through their "next" field.
480 After doing the mark phase, GC will walk this linked list
481 and free any lcrecord which hasn't been marked. */
482 static struct lcrecord_header *all_lcrecords;
486 #if defined USE_MLY_UIDS
487 #define lcheader_set_uid(_x) (_x)->uid = lrecord_uid_counter++
488 #elif defined USE_JWZ_UIDS
489 #define lcheader_set_uid(_x) (_x)->uid = (long int)&(_x)
492 void *alloc_lcrecord(size_t size,
493 const struct lrecord_implementation *implementation)
495 struct lcrecord_header *lcheader;
498 ((implementation->static_size == 0 ?
499 implementation->size_in_bytes_method != NULL :
500 implementation->static_size == size)
501 && (!implementation->basic_p)
503 (!(implementation->hash == NULL
504 && implementation->equal != NULL)));
507 lcheader = (struct lcrecord_header *)allocate_lisp_storage(size);
508 lcrec_register_finaliser(lcheader);
509 set_lheader_implementation(&lcheader->lheader, implementation);
511 lcheader_set_uid(lcheader);
513 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
514 lcheader->next = all_lcrecords;
515 all_lcrecords = lcheader;
516 INCREMENT_CONS_COUNTER(size, implementation->name);
522 static void disksave_object_finalization_1(void)
524 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
525 struct lcrecord_header *header;
527 for (header = all_lcrecords; header; header = header->next) {
528 if (LHEADER_IMPLEMENTATION(&header->lheader)->finalizer &&
530 LHEADER_IMPLEMENTATION(&header->lheader)->
531 finalizer(header, 1);
536 /************************************************************************/
537 /* Debugger support */
538 /************************************************************************/
539 /* Give gdb/dbx enough information to decode Lisp Objects. We make
540 sure certain symbols are always defined, so gdb doesn't complain
541 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
542 to see how this is used. */
544 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
545 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
547 unsigned char dbg_valbits = VALBITS;
548 unsigned char dbg_gctypebits = GCTYPEBITS;
550 /* On some systems, the above definitions will be optimized away by
551 the compiler or linker unless they are referenced in some function. */
552 long dbg_inhibit_dbg_symbol_deletion(void);
553 long dbg_inhibit_dbg_symbol_deletion(void)
555 return (dbg_valmask + dbg_typemask + dbg_valbits + dbg_gctypebits);
558 /* Macros turned into functions for ease of debugging.
559 Debuggers don't know about macros! */
560 int dbg_eq(Lisp_Object obj1, Lisp_Object obj2);
561 int dbg_eq(Lisp_Object obj1, Lisp_Object obj2)
563 return EQ(obj1, obj2);
566 /************************************************************************/
567 /* Fixed-size type macros */
568 /************************************************************************/
570 /* For fixed-size types that are commonly used, we malloc() large blocks
571 of memory at a time and subdivide them into chunks of the correct
572 size for an object of that type. This is more efficient than
573 malloc()ing each object separately because we save on malloc() time
574 and overhead due to the fewer number of malloc()ed blocks, and
575 also because we don't need any extra pointers within each object
576 to keep them threaded together for GC purposes. For less common
577 (and frequently large-size) types, we use lcrecords, which are
578 malloc()ed individually and chained together through a pointer
579 in the lcrecord header. lcrecords do not need to be fixed-size
580 (i.e. two objects of the same type need not have the same size;
581 however, the size of a particular object cannot vary dynamically).
582 It is also much easier to create a new lcrecord type because no
583 additional code needs to be added to alloc.c. Finally, lcrecords
584 may be more efficient when there are only a small number of them.
586 The types that are stored in these large blocks (or "frob blocks")
587 are cons, float, compiled-function, symbol, marker, extent, event,
590 Note that strings are special in that they are actually stored in
591 two parts: a structure containing information about the string, and
592 the actual data associated with the string. The former structure
593 (a struct Lisp_String) is a fixed-size structure and is managed the
594 same way as all the other such types. This structure contains a
595 pointer to the actual string data, which is stored in structures of
596 type struct string_chars_block. Each string_chars_block consists
597 of a pointer to a struct Lisp_String, followed by the data for that
598 string, followed by another pointer to a Lisp_String, followed by
599 the data for that string, etc. At GC time, the data in these
600 blocks is compacted by searching sequentially through all the
601 blocks and compressing out any holes created by unmarked strings.
602 Strings that are more than a certain size (bigger than the size of
603 a string_chars_block, although something like half as big might
604 make more sense) are malloc()ed separately and not stored in
605 string_chars_blocks. Furthermore, no one string stretches across
606 two string_chars_blocks.
608 Vectors are each malloc()ed separately, similar to lcrecords.
610 In the following discussion, we use conses, but it applies equally
611 well to the other fixed-size types.
613 We store cons cells inside of cons_blocks, allocating a new
614 cons_block with malloc() whenever necessary. Cons cells reclaimed
615 by GC are put on a free list to be reallocated before allocating
616 any new cons cells from the latest cons_block. Each cons_block is
617 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
618 the versions in malloc.c and gmalloc.c) really allocates in units
619 of powers of two and uses 4 bytes for its own overhead.
621 What GC actually does is to search through all the cons_blocks,
622 from the most recently allocated to the oldest, and put all
623 cons cells that are not marked (whether or not they're already
624 free) on a cons_free_list. The cons_free_list is a stack, and
625 so the cons cells in the oldest-allocated cons_block end up
626 at the head of the stack and are the first to be reallocated.
627 If any cons_block is entirely free, it is freed with free()
628 and its cons cells removed from the cons_free_list. Because
629 the cons_free_list ends up basically in memory order, we have
630 a high locality of reference (assuming a reasonable turnover
631 of allocating and freeing) and have a reasonable probability
632 of entirely freeing up cons_blocks that have been more recently
633 allocated. This stage is called the "sweep stage" of GC, and
634 is executed after the "mark stage", which involves starting
635 from all places that are known to point to in-use Lisp objects
636 (e.g. the obarray, where are all symbols are stored; the
637 current catches and condition-cases; the backtrace list of
638 currently executing functions; the gcpro list; etc.) and
639 recursively marking all objects that are accessible.
641 At the beginning of the sweep stage, the conses in the cons blocks
642 are in one of three states: in use and marked, in use but not
643 marked, and not in use (already freed). Any conses that are marked
644 have been marked in the mark stage just executed, because as part
645 of the sweep stage we unmark any marked objects. The way we tell
646 whether or not a cons cell is in use is through the LRECORD_FREE_P
647 macro. This uses a special lrecord type `lrecord_type_free',
648 which is never associated with any valid object.
650 Conses on the free_cons_list are threaded through a pointer stored
651 in the conses themselves. Because the cons is still in a
652 cons_block and needs to remain marked as not in use for the next
653 time that GC happens, we need room to store both the "free"
654 indicator and the chaining pointer. So this pointer is stored
655 after the lrecord header (actually where C places a pointer after
656 the lrecord header; they are not necessarily contiguous). This
657 implies that all fixed-size types must be big enough to contain at
658 least one pointer. This is true for all current fixed-size types,
659 with the possible exception of Lisp_Floats, for which we define the
660 meat of the struct using a union of a pointer and a double to
661 ensure adequate space for the free list chain pointer.
663 Some types of objects need additional "finalization" done
664 when an object is converted from in use to not in use;
665 this is the purpose of the ADDITIONAL_FREE_type macro.
666 For example, markers need to be removed from the chain
667 of markers that is kept in each buffer. This is because
668 markers in a buffer automatically disappear if the marker
669 is no longer referenced anywhere (the same does not
670 apply to extents, however).
672 WARNING: Things are in an extremely bizarre state when
673 the ADDITIONAL_FREE_type macros are called, so beware!
675 When ERROR_CHECK_GC is defined, we do things differently so as to
676 maximize our chances of catching places where there is insufficient
677 GCPROing. The thing we want to avoid is having an object that
678 we're using but didn't GCPRO get freed by GC and then reallocated
679 while we're in the process of using it -- this will result in
680 something seemingly unrelated getting trashed, and is extremely
681 difficult to track down. If the object gets freed but not
682 reallocated, we can usually catch this because we set most of the
683 bytes of a freed object to 0xDEADBEEF. (The lisp object type is set
684 to the invalid type `lrecord_type_free', however, and a pointer
685 used to chain freed objects together is stored after the lrecord
686 header; we play some tricks with this pointer to make it more
687 bogus, so crashes are more likely to occur right away.)
689 We want freed objects to stay free as long as possible,
690 so instead of doing what we do above, we maintain the
691 free objects in a first-in first-out queue. We also
692 don't recompute the free list each GC, unlike above;
693 this ensures that the queue ordering is preserved.
694 [This means that we are likely to have worse locality
695 of reference, and that we can never free a frob block
696 once it's allocated. (Even if we know that all cells
697 in it are free, there's no easy way to remove all those
698 cells from the free list because the objects on the
699 free list are unlikely to be in memory order.)]
700 Furthermore, we never take objects off the free list
701 unless there's a large number (usually 1000, but
702 varies depending on type) of them already on the list.
703 This way, we ensure that an object that gets freed will
704 remain free for the next 1000 (or whatever) times that
705 an object of that type is allocated. */
707 #ifndef MALLOC_OVERHEAD
709 #define MALLOC_OVERHEAD 0
710 #elif defined (rcheck)
711 #define MALLOC_OVERHEAD 20
713 #define MALLOC_OVERHEAD 8
715 #endif /* MALLOC_OVERHEAD */
717 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
718 /* If we released our reserve (due to running out of memory),
719 and we have a fair amount free once again,
720 try to set aside another reserve in case we run out once more.
722 This is called when a relocatable block is freed in ralloc.c. */
723 void refill_memory_reserve(void);
724 void refill_memory_reserve(void)
726 if (breathing_space == NULL) {
727 breathing_space = malloc(0xFFFF - MALLOC_OVERHEAD);
730 #endif /* !HAVE_MMAP || DOUG_LEA_MALLOC */
732 #ifdef ALLOC_NO_POOLS
733 # define TYPE_ALLOC_SIZE(type, structtype) 1
735 # define TYPE_ALLOC_SIZE(type, structtype) \
736 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
737 / sizeof (structtype))
738 #endif /* ALLOC_NO_POOLS */
740 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
741 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
743 init_##type##_alloc(void) \
748 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
750 struct type##_block \
752 struct type##_block *prev; \
753 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
756 static struct type##_block *current_##type##_block; \
757 static int current_##type##_block_index; \
759 static Lisp_Free *type##_free_list; \
760 static Lisp_Free *type##_free_list_tail; \
763 init_##type##_alloc (void) \
765 current_##type##_block = 0; \
766 current_##type##_block_index = \
767 countof (current_##type##_block->block); \
768 type##_free_list = 0; \
769 type##_free_list_tail = 0; \
772 static int gc_count_num_##type##_in_use; \
773 static int gc_count_num_##type##_freelist
774 #endif /* HAVE_BDWGC */
776 /* no need for a case distinction, shouldn't be called in bdwgc mode */
777 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) \
779 if (current_##type##_block_index \
780 == countof (current_##type##_block->block)) { \
781 struct type##_block *AFTFB_new = \
782 (struct type##_block *) \
783 allocate_lisp_storage( \
784 sizeof (struct type##_block)); \
785 AFTFB_new->prev = current_##type##_block; \
786 current_##type##_block = AFTFB_new; \
787 current_##type##_block_index = 0; \
789 (result) = &(current_##type##_block \
790 ->block[current_##type##_block_index++]); \
793 /* Allocate an instance of a type that is stored in blocks.
794 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
797 #ifdef ERROR_CHECK_GC
799 /* Note: if you get crashes in this function, suspect incorrect calls
800 to free_cons() and friends. This happened once because the cons
801 cell was not GC-protected and was getting collected before
802 free_cons() was called. */
804 /* no need for a case distinction, shouldn't be called in bdwgc mode */
805 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
808 if (gc_count_num_##type##_freelist > \
809 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) { \
810 result = (structtype *) type##_free_list; \
811 /* Before actually using the chain pointer, \
812 we complement all its bits; \
813 see FREE_FIXED_TYPE(). */ \
814 type##_free_list = (Lisp_Free *) \
816 (type##_free_list->chain)); \
817 gc_count_num_##type##_freelist--; \
819 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
821 MARK_LRECORD_AS_NOT_FREE (result); \
822 unlock_allocator(); \
825 #else /* !ERROR_CHECK_GC */
827 /* no need for a case distinction, shouldn't be called in bdwgc mode */
828 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
830 if (type##_free_list) { \
831 result = (structtype *) type##_free_list; \
832 type##_free_list = type##_free_list->chain; \
834 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
836 MARK_LRECORD_AS_NOT_FREE (result); \
838 #endif /* !ERROR_CHECK_GC */
840 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
842 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
844 result = xnew(structtype); \
845 assert(result != NULL); \
846 INCREMENT_CONS_COUNTER(sizeof(structtype), #type); \
848 #define ALLOCATE_ATOMIC_FIXED_TYPE(type, structtype, result) \
850 result = xnew_atomic(structtype); \
851 assert(result != NULL); \
852 INCREMENT_CONS_COUNTER(sizeof(structtype), #type); \
857 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
859 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
860 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
862 #define ALLOCATE_ATOMIC_FIXED_TYPE ALLOCATE_FIXED_TYPE
866 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
867 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
868 (result) = xnew(structtype)
870 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
872 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
873 NOSEEUM_INCREMENT_CONS_COUNTER(sizeof (structtype), #type); \
877 /* Lisp_Free is the type to represent a free list member inside a frob
878 block of any lisp object type. */
879 typedef struct Lisp_Free {
880 struct lrecord_header lheader;
881 struct Lisp_Free *chain;
884 #define LRECORD_FREE_P(ptr) \
885 ((ptr)->lheader.type == lrecord_type_free)
887 #define MARK_LRECORD_AS_FREE(ptr) \
888 ((void) ((ptr)->lheader.type = lrecord_type_free))
890 #ifdef ERROR_CHECK_GC
891 #define MARK_LRECORD_AS_NOT_FREE(ptr) \
892 ((void) ((ptr)->lheader.type = lrecord_type_undefined))
894 #define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING
897 #ifdef ERROR_CHECK_GC
899 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
901 if (type##_free_list_tail) { \
902 /* When we store the chain pointer, we \
903 complement all its bits; this should \
904 significantly increase its bogosity in case \
905 someone tries to use the value, and \
906 should make us crash faster if someone \
907 overwrites the pointer because when it gets \
908 un-complemented in ALLOCATED_FIXED_TYPE(), \
909 the resulting pointer will be extremely \
911 type##_free_list_tail->chain = \
912 (Lisp_Free *) ~ (EMACS_UINT) (ptr); \
914 type##_free_list = (Lisp_Free *) (ptr); \
916 type##_free_list_tail = (Lisp_Free *) (ptr); \
919 #else /* !ERROR_CHECK_GC */
921 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
923 ((Lisp_Free *) (ptr))->chain = type##_free_list; \
924 type##_free_list = (Lisp_Free *) (ptr); \
927 #endif /* !ERROR_CHECK_GC */
929 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
931 #define FREE_FIXED_TYPE(type, structtype, ptr) \
933 structtype *FFT_ptr = (ptr); \
934 ADDITIONAL_FREE_##type (FFT_ptr); \
935 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
936 PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, FFT_ptr); \
937 MARK_LRECORD_AS_FREE (FFT_ptr); \
940 /* Like FREE_FIXED_TYPE() but used when we are explicitly
941 freeing a structure through free_cons(), free_marker(), etc.
942 rather than through the normal process of sweeping.
943 We attempt to undo the changes made to the allocation counters
944 as a result of this structure being allocated. This is not
945 completely necessary but helps keep things saner: e.g. this way,
946 repeatedly allocating and freeing a cons will not result in
947 the consing-since-gc counter advancing, which would cause a GC
948 and somewhat defeat the purpose of explicitly freeing. */
950 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
951 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr)
952 #else /* !HAVE_BDWGC */
953 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
955 FREE_FIXED_TYPE (type, structtype, ptr); \
956 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
957 gc_count_num_##type##_freelist++; \
959 #endif /* HAVE_BDWGC */
961 /************************************************************************/
962 /* Cons allocation */
963 /************************************************************************/
965 DECLARE_FIXED_TYPE_ALLOC(cons, Lisp_Cons);
966 /* conses are used and freed so often that we set this really high */
967 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
968 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
970 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
972 cons_register_finaliser(Lisp_Cons *s)
974 GC_finalization_proc *foo = NULL;
976 auto void cons_finaliser();
978 auto void cons_finaliser(void *obj, void *SXE_UNUSED(data))
981 memset(obj, 0, sizeof(Lisp_Cons));
985 SXE_DEBUG_GC("cons-fina %p\n", s);
986 GC_REGISTER_FINALIZER(s, cons_finaliser, NULL, foo, bar);
991 cons_register_finaliser(Lisp_Cons *SXE_UNUSED(b))
995 #endif /* HAVE_BDWGC */
997 static Lisp_Object mark_cons(Lisp_Object obj)
1002 mark_object(XCAR(obj));
1006 static int cons_equal(Lisp_Object ob1, Lisp_Object ob2, int depth)
1009 while (internal_equal(XCAR(ob1), XCAR(ob2), depth)) {
1012 if (!CONSP(ob1) || !CONSP(ob2))
1013 return internal_equal(ob1, ob2, depth);
1018 /* the seq approach for conses */
1020 cons_length(const seq_t cons)
1023 GET_EXTERNAL_LIST_LENGTH((Lisp_Object)cons, len);
1028 cons_iter_init(seq_t cons, seq_iter_t si)
1030 si->data = si->seq = cons;
1035 cons_iter_next(seq_iter_t si, void **elt)
1037 if (si->data != NULL && CONSP(si->data)) {
1038 *elt = (void*)((Lisp_Cons*)si->data)->car;
1039 si->data = (void*)((Lisp_Cons*)si->data)->cdr;
1047 cons_iter_fini(seq_iter_t si)
1049 si->data = si->seq = NULL;
1054 cons_iter_reset(seq_iter_t si)
1061 cons_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
1063 volatile size_t i = 0;
1064 volatile Lisp_Object c = (Lisp_Object)s;
1066 while (CONSP(c) && i < ntgt) {
1067 tgt[i++] = (void*)XCAR(c);
1073 static struct seq_impl_s __scons = {
1074 .length_f = cons_length,
1075 .iter_init_f = cons_iter_init,
1076 .iter_next_f = cons_iter_next,
1077 .iter_fini_f = cons_iter_fini,
1078 .iter_reset_f = cons_iter_reset,
1079 .explode_f = cons_explode,
1082 static const struct lrecord_description cons_description[] = {
1083 {XD_LISP_OBJECT, offsetof(Lisp_Cons, car)},
1084 {XD_LISP_OBJECT, offsetof(Lisp_Cons, cdr)},
1088 DEFINE_BASIC_LRECORD_IMPLEMENTATION("cons", cons,
1089 mark_cons, print_cons, 0, cons_equal,
1091 * No `hash' method needed.
1092 * internal_hash knows how to
1095 0, cons_description, Lisp_Cons);
1097 DEFUN("cons", Fcons, 2, 2, 0, /*
1098 Create a new cons, give it CAR and CDR as components, and return it.
1100 A cons cell is a Lisp object (an area in memory) made up of two pointers
1101 called the CAR and the CDR. Each of these pointers can point to any other
1102 Lisp object. The common Lisp data type, the list, is a specially-structured
1103 series of cons cells.
1105 The pointers are accessed from Lisp with `car' and `cdr', and mutated with
1106 `setcar' and `setcdr' respectively. For historical reasons, the aliases
1107 `rplaca' and `rplacd' (for `setcar' and `setcdr') are supported.
1111 /* This cannot GC. */
1115 ALLOCATE_FIXED_TYPE(cons, Lisp_Cons, c);
1116 set_lheader_implementation(&c->lheader, &lrecord_cons);
1117 cons_register_finaliser(c);
1121 /* propagate the cat system, go with the standard impl of a seq first */
1122 c->lheader.morphisms = 0;
1126 /* This is identical to Fcons() but it used for conses that we're
1127 going to free later, and is useful when trying to track down
1129 Lisp_Object noseeum_cons(Lisp_Object car, Lisp_Object cdr)
1134 NOSEEUM_ALLOCATE_FIXED_TYPE(cons, Lisp_Cons, c);
1135 set_lheader_implementation(&c->lheader, &lrecord_cons);
1139 /* propagate the cat system, go with the standard impl of a seq first */
1140 c->lheader.morphisms = 0;
1144 DEFUN("list", Flist, 0, MANY, 0, /*
1145 Return a newly created list with specified arguments as elements.
1146 Any number of arguments, even zero arguments, are allowed.
1148 (int nargs, Lisp_Object * args))
1150 Lisp_Object val = Qnil;
1151 Lisp_Object *argp = args + nargs;
1154 val = Fcons(*--argp, val);
1158 Lisp_Object list1(Lisp_Object obj0)
1160 /* This cannot GC. */
1161 return Fcons(obj0, Qnil);
1164 Lisp_Object list2(Lisp_Object obj0, Lisp_Object obj1)
1166 /* This cannot GC. */
1167 return Fcons(obj0, Fcons(obj1, Qnil));
1170 Lisp_Object list3(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1172 /* This cannot GC. */
1173 return Fcons(obj0, Fcons(obj1, Fcons(obj2, Qnil)));
1176 Lisp_Object cons3(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1178 /* This cannot GC. */
1179 return Fcons(obj0, Fcons(obj1, obj2));
1182 Lisp_Object acons(Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1184 return Fcons(Fcons(key, value), alist);
1188 list4(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1190 /* This cannot GC. */
1191 return Fcons(obj0, Fcons(obj1, Fcons(obj2, Fcons(obj3, Qnil))));
1195 list5(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1198 /* This cannot GC. */
1200 Fcons(obj1, Fcons(obj2, Fcons(obj3, Fcons(obj4, Qnil)))));
1204 list6(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1205 Lisp_Object obj4, Lisp_Object obj5)
1207 /* This cannot GC. */
1211 Fcons(obj3, Fcons(obj4, Fcons(obj5, Qnil))))));
1214 DEFUN("make-list", Fmake_list, 2, 2, 0, /*
1215 Return a new list of length LENGTH, with each element being OBJECT.
1219 CHECK_NATNUM(length);
1222 Lisp_Object val = Qnil;
1223 size_t size = XINT(length);
1226 val = Fcons(object, val);
1231 /************************************************************************/
1232 /* Float allocation */
1233 /************************************************************************/
1234 /* used by many of the allocators below */
1235 #include "ent/ent.h"
1240 DECLARE_FIXED_TYPE_ALLOC(float, Lisp_Float);
1241 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1243 Lisp_Object make_float(fpfloat float_value)
1248 if (ENT_FLOAT_PINF_P(float_value))
1249 return make_indef(POS_INFINITY);
1250 else if (ENT_FLOAT_NINF_P(float_value))
1251 return make_indef(NEG_INFINITY);
1252 else if (ENT_FLOAT_NAN_P(float_value))
1253 return make_indef(NOT_A_NUMBER);
1255 ALLOCATE_FIXED_TYPE(float, Lisp_Float, f);
1257 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1258 if (sizeof(struct lrecord_header) +
1259 sizeof(fpfloat) != sizeof(*f))
1262 set_lheader_implementation(&f->lheader, &lrecord_float);
1263 float_data(f) = float_value;
1268 #endif /* HAVE_FPFLOAT */
1270 /************************************************************************/
1271 /* Enhanced number allocation */
1272 /************************************************************************/
1275 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1276 DECLARE_FIXED_TYPE_ALLOC(bigz, Lisp_Bigz);
1277 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigz 250
1279 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1281 bigz_register_finaliser(Lisp_Bigz *b)
1283 GC_finalization_proc *foo = NULL;
1285 auto void bigz_finaliser();
1287 auto void bigz_finaliser(void *obj, void *SXE_UNUSED(data))
1289 bigz_fini(bigz_data((Lisp_Bigz*)obj));
1291 memset(obj, 0, sizeof(Lisp_Bigz));
1295 GC_REGISTER_FINALIZER(b, bigz_finaliser, NULL, foo, bar);
1300 bigz_register_finaliser(Lisp_Bigz *SXE_UNUSED(b))
1304 #endif /* HAVE_BDWGC */
1306 /* WARNING: This function returns a bignum even if its argument fits into a
1307 fixnum. See Fcanonicalize_number(). */
1309 make_bigz (long bigz_value)
1313 ALLOCATE_FIXED_TYPE(bigz, Lisp_Bigz, b);
1314 bigz_register_finaliser(b);
1316 set_lheader_implementation(&b->lheader, &lrecord_bigz);
1317 bigz_init(bigz_data(b));
1318 bigz_set_long(bigz_data(b), bigz_value);
1319 return wrap_bigz(b);
1322 /* WARNING: This function returns a bigz even if its argument fits into a
1323 fixnum. See Fcanonicalize_number(). */
1325 make_bigz_bz (bigz bz)
1329 ALLOCATE_FIXED_TYPE(bigz, Lisp_Bigz, b);
1330 bigz_register_finaliser(b);
1332 set_lheader_implementation(&b->lheader, &lrecord_bigz);
1333 bigz_init(bigz_data(b));
1334 bigz_set(bigz_data(b), bz);
1335 return wrap_bigz(b);
1337 #endif /* HAVE_MPZ */
1340 #if defined HAVE_MPQ && defined WITH_GMP
1341 DECLARE_FIXED_TYPE_ALLOC(bigq, Lisp_Bigq);
1342 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigq 250
1344 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1346 bigq_register_finaliser(Lisp_Bigq *b)
1348 GC_finalization_proc *foo = NULL;
1350 auto void bigq_finaliser();
1352 auto void bigq_finaliser(void *obj, void *SXE_UNUSED(data))
1354 bigq_fini(bigq_data((Lisp_Bigq*)obj));
1356 memset(obj, 0, sizeof(Lisp_Bigq));
1360 GC_REGISTER_FINALIZER(b, bigq_finaliser, NULL, foo, bar);
1365 bigq_register_finaliser(Lisp_Bigq *SXE_UNUSED(b))
1369 #endif /* HAVE_BDWGC */
1372 make_bigq(long numerator, unsigned long denominator)
1376 ALLOCATE_FIXED_TYPE(bigq, Lisp_Bigq, r);
1377 bigq_register_finaliser(r);
1379 set_lheader_implementation(&r->lheader, &lrecord_bigq);
1380 bigq_init(bigq_data(r));
1381 bigq_set_long_ulong(bigq_data(r), numerator, denominator);
1382 bigq_canonicalize(bigq_data(r));
1383 return wrap_bigq(r);
1387 make_bigq_bz(bigz numerator, bigz denominator)
1391 ALLOCATE_FIXED_TYPE(bigq, Lisp_Bigq, r);
1392 bigq_register_finaliser(r);
1394 set_lheader_implementation(&r->lheader, &lrecord_bigq);
1395 bigq_init(bigq_data(r));
1396 bigq_set_bigz_bigz(bigq_data(r), numerator, denominator);
1397 bigq_canonicalize(bigq_data(r));
1398 return wrap_bigq(r);
1402 make_bigq_bq(bigq rat)
1406 ALLOCATE_FIXED_TYPE(bigq, Lisp_Bigq, r);
1407 bigq_register_finaliser(r);
1409 set_lheader_implementation(&r->lheader, &lrecord_bigq);
1410 bigq_init(bigq_data(r));
1411 bigq_set(bigq_data(r), rat);
1412 return wrap_bigq(r);
1414 #endif /* HAVE_MPQ */
1417 #if defined HAVE_MPF && defined WITH_GMP
1418 DECLARE_FIXED_TYPE_ALLOC(bigf, Lisp_Bigf);
1419 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigf 250
1421 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1423 bigf_register_finaliser(Lisp_Bigf *b)
1425 GC_finalization_proc *foo = NULL;
1427 auto void bigf_finaliser();
1429 auto void bigf_finaliser(void *obj, void *SXE_UNUSED(data))
1431 bigf_fini(bigf_data((Lisp_Bigf*)obj));
1433 memset(obj, 0, sizeof(Lisp_Bigf));
1437 GC_REGISTER_FINALIZER(b, bigf_finaliser, NULL, foo, bar);
1442 bigf_register_finaliser(Lisp_Bigf *SXE_UNUSED(b))
1446 #endif /* HAVE_BDWGC */
1448 /* This function creates a bigfloat with the default precision if the
1449 PRECISION argument is zero. */
1451 make_bigf(fpfloat float_value, unsigned long precision)
1455 ALLOCATE_FIXED_TYPE(bigf, Lisp_Bigf, f);
1456 bigf_register_finaliser(f);
1458 set_lheader_implementation(&f->lheader, &lrecord_bigf);
1459 if (precision == 0UL)
1460 bigf_init(bigf_data(f));
1462 bigf_init_prec(bigf_data(f), precision);
1463 bigf_set_fpfloat(bigf_data(f), float_value);
1464 return wrap_bigf(f);
1467 /* This function creates a bigfloat with the precision of its argument */
1469 make_bigf_bf(bigf float_value)
1473 ALLOCATE_FIXED_TYPE(bigf, Lisp_Bigf, f);
1474 bigf_register_finaliser(f);
1476 set_lheader_implementation(&f->lheader, &lrecord_bigf);
1477 bigf_init_prec(bigf_data(f), bigf_get_prec(float_value));
1478 bigf_set(bigf_data(f), float_value);
1479 return wrap_bigf(f);
1481 #endif /* HAVE_MPF */
1483 /*** Bigfloat with correct rounding ***/
1484 #if defined HAVE_MPFR && defined WITH_MPFR
1485 DECLARE_FIXED_TYPE_ALLOC(bigfr, Lisp_Bigfr);
1486 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigfr 250
1488 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1490 bigfr_register_finaliser(Lisp_Bigfr *b)
1492 GC_finalization_proc *foo = NULL;
1494 auto void bigfr_finaliser();
1496 auto void bigfr_finaliser(void *obj, void *SXE_UNUSED(data))
1498 bigfr_fini(bigfr_data((Lisp_Bigfr*)obj));
1500 memset(obj, 0, sizeof(Lisp_Bigfr));
1504 GC_REGISTER_FINALIZER(b, bigfr_finaliser, NULL, foo, bar);
1509 bigfr_register_finaliser(Lisp_Bigfr *SXE_UNUSED(b))
1513 #endif /* HAVE_BDWGC */
1515 /* This function creates a bigfloat with the default precision if the
1516 PRECISION argument is zero. */
1518 make_bigfr(fpfloat float_value, unsigned long precision)
1522 ALLOCATE_FIXED_TYPE(bigfr, Lisp_Bigfr, f);
1523 set_lheader_implementation(&f->lheader, &lrecord_bigfr);
1524 bigfr_register_finaliser(f);
1526 if (precision == 0UL) {
1527 bigfr_init(bigfr_data(f));
1529 bigfr_init_prec(bigfr_data(f), precision);
1531 bigfr_set_fpfloat(bigfr_data(f), float_value);
1532 return wrap_bigfr(f);
1535 /* This function creates a bigfloat with the precision of its argument */
1537 make_bigfr_bf(bigf float_value)
1541 ALLOCATE_FIXED_TYPE(bigfr, Lisp_Bigfr, f);
1542 set_lheader_implementation(&f->lheader, &lrecord_bigfr);
1543 bigfr_register_finaliser(f);
1545 bigfr_init_prec(bigfr_data(f), bigf_get_prec(float_value));
1546 bigfr_set_bigf(bigfr_data(f), float_value);
1547 return wrap_bigfr(f);
1550 /* This function creates a bigfloat with the precision of its argument */
1552 make_bigfr_bfr(bigfr bfr_value)
1556 if (bigfr_nan_p(bfr_value) || bigfr_inf_p(bfr_value)) {
1557 return make_indef_bfr(bfr_value);
1560 ALLOCATE_FIXED_TYPE(bigfr, Lisp_Bigfr, f);
1561 set_lheader_implementation(&f->lheader, &lrecord_bigfr);
1562 bigfr_register_finaliser(f);
1564 bigfr_init_prec(bigfr_data(f), bigfr_get_prec(bfr_value));
1565 bigfr_set(bigfr_data(f), bfr_value);
1566 return wrap_bigfr(f);
1568 #endif /* HAVE_MPFR */
1570 /*** Big gaussian numbers ***/
1571 #if defined HAVE_PSEUG && defined HAVE_MPZ && defined WITH_PSEUG
1572 DECLARE_FIXED_TYPE_ALLOC(bigg, Lisp_Bigg);
1573 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigg 250
1575 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1577 bigg_register_finaliser(Lisp_Bigg *b)
1579 GC_finalization_proc *foo = NULL;
1581 auto void bigg_finaliser();
1583 auto void bigg_finaliser(void *obj, void *SXE_UNUSED(data))
1585 bigg_fini(bigg_data((Lisp_Bigg*)obj));
1587 memset(obj, 0, sizeof(Lisp_Bigg));
1591 GC_REGISTER_FINALIZER(b, bigg_finaliser, NULL, foo, bar);
1596 bigg_register_finaliser(Lisp_Bigg *SXE_UNUSED(b))
1600 #endif /* HAVE_BDWGC */
1602 /* This function creates a gaussian number. */
1604 make_bigg(long intg, long imag)
1608 ALLOCATE_FIXED_TYPE(bigg, Lisp_Bigg, g);
1609 set_lheader_implementation(&g->lheader, &lrecord_bigg);
1610 bigg_register_finaliser(g);
1612 bigg_init(bigg_data(g));
1613 bigg_set_long_long(bigg_data(g), intg, imag);
1614 return wrap_bigg(g);
1617 /* This function creates a complex with the precision of its argument */
1619 make_bigg_bz(bigz intg, bigz imag)
1623 ALLOCATE_FIXED_TYPE(bigg, Lisp_Bigg, g);
1624 set_lheader_implementation(&g->lheader, &lrecord_bigg);
1625 bigg_register_finaliser(g);
1627 bigg_init(bigg_data(g));
1628 bigg_set_bigz_bigz(bigg_data(g), intg, imag);
1629 return wrap_bigg(g);
1632 /* This function creates a complex with the precision of its argument */
1634 make_bigg_bg(bigg gaussian_value)
1638 ALLOCATE_FIXED_TYPE(bigg, Lisp_Bigg, g);
1639 set_lheader_implementation(&g->lheader, &lrecord_bigg);
1640 bigg_register_finaliser(g);
1642 bigg_init(bigg_data(g));
1643 bigg_set(bigg_data(g), gaussian_value);
1644 return wrap_bigg(g);
1646 #endif /* HAVE_PSEUG */
1648 /*** Big complex numbers with correct rounding ***/
1649 #if defined HAVE_MPC && defined WITH_MPC || \
1650 defined HAVE_PSEUC && defined WITH_PSEUC
1651 DECLARE_FIXED_TYPE_ALLOC(bigc, Lisp_Bigc);
1652 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigc 250
1654 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1656 bigc_register_finaliser(Lisp_Bigc *b)
1658 GC_finalization_proc *foo = NULL;
1660 auto void bigc_finaliser();
1662 auto void bigc_finaliser(void *obj, void *SXE_UNUSED(data))
1664 bigc_fini(bigc_data((Lisp_Bigc*)obj));
1666 memset(obj, 0, sizeof(Lisp_Bigc));
1670 GC_REGISTER_FINALIZER(b, bigc_finaliser, NULL, foo, bar);
1675 bigc_register_finaliser(Lisp_Bigc *SXE_UNUSED(b))
1679 #endif /* HAVE_BDWGC */
1681 /* This function creates a bigfloat with the default precision if the
1682 PRECISION argument is zero. */
1684 make_bigc(fpfloat re_value, fpfloat im_value, unsigned long precision)
1688 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1689 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1690 bigc_register_finaliser(c);
1692 if (precision == 0UL) {
1693 bigc_init(bigc_data(c));
1695 bigc_init_prec(bigc_data(c), precision);
1697 bigc_set_fpfloat_fpfloat(bigc_data(c), re_value, im_value);
1698 return wrap_bigc(c);
1701 /* This function creates a complex with the precision of its argument */
1703 make_bigc_bfr(bigfr re_value, bigfr im_value, unsigned long precision)
1707 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1708 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1709 bigc_register_finaliser(c);
1711 if (precision == 0UL) {
1712 bigc_init(bigc_data(c));
1714 bigc_init_prec(bigc_data(c), precision);
1716 bigc_set_bigfr_bigfr(bigc_data(c), re_value, im_value);
1717 return wrap_bigc(c);
1720 /* This function creates a complex with the precision of its argument */
1722 make_bigc_bc(bigc complex_value)
1726 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1727 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1728 bigc_register_finaliser(c);
1730 bigc_init_prec(bigc_data(c), bigc_get_prec(complex_value));
1731 bigc_set(bigc_data(c), complex_value);
1732 return wrap_bigc(c);
1734 #endif /* HAVE_MPC */
1736 /*** Quaternions ***/
1737 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
1738 DECLARE_FIXED_TYPE_ALLOC(quatern, Lisp_Quatern);
1739 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_quatern 250
1741 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1743 quatern_register_finaliser(Lisp_Quatern *b)
1745 GC_finalization_proc *foo = NULL;
1747 auto void quatern_finaliser();
1749 auto void quatern_finaliser(void *obj, void *SXE_UNUSED(data))
1751 quatern_fini(quatern_data((Lisp_Quatern*)obj));
1753 memset(obj, 0, sizeof(Lisp_Quatern));
1757 GC_REGISTER_FINALIZER(b, quatern_finaliser, NULL, foo, bar);
1762 quatern_register_finaliser(Lisp_Quatern *SXE_UNUSED(b))
1766 #endif /* HAVE_BDWGC */
1768 /* This function creates a quaternion. */
1770 make_quatern(EMACS_INT z, EMACS_INT i, EMACS_INT j, EMACS_INT k)
1774 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1775 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1776 quatern_register_finaliser(g);
1778 quatern_init(quatern_data(g));
1779 quatern_set_long_long_long_long(quatern_data(g), z, i, j, k);
1780 return wrap_quatern(g);
1784 make_quatern_bz(bigz z, bigz i, bigz j, bigz k)
1788 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1789 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1790 quatern_register_finaliser(g);
1792 quatern_init(quatern_data(g));
1793 quatern_set_bigz_bigz_bigz_bigz(quatern_data(g), z, i, j, k);
1794 return wrap_quatern(g);
1798 make_quatern_qu(quatern quaternion)
1802 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1803 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1804 quatern_register_finaliser(g);
1806 quatern_init(quatern_data(g));
1807 quatern_set(quatern_data(g), quaternion);
1808 return wrap_quatern(g);
1810 #endif /* HAVE_QUATERN */
1813 make_indef_internal(indef sym)
1817 i = allocate_lisp_storage(sizeof(Lisp_Indef));
1818 set_lheader_implementation(&i->lheader, &lrecord_indef);
1819 indef_data(i) = sym;
1820 return wrap_indef(i);
1824 make_indef(indef sym)
1831 case COMPLEX_INFINITY:
1832 return Vcomplex_infinity;
1835 /* list some more here */
1836 case END_OF_COMPARABLE_INFINITIES:
1837 case END_OF_INFINITIES:
1839 return Vnot_a_number;
1843 #if defined HAVE_MPFR && defined WITH_MPFR
1845 make_indef_bfr(bigfr bfr_value)
1847 if (bigfr_nan_p(bfr_value)) {
1848 return make_indef(NOT_A_NUMBER);
1849 } else if (bigfr_inf_p(bfr_value)) {
1850 if (bigfr_sign(bfr_value) > 0)
1851 return make_indef(POS_INFINITY);
1853 return make_indef(NEG_INFINITY);
1855 return make_indef(NOT_A_NUMBER);
1860 DECLARE_FIXED_TYPE_ALLOC(dynacat, struct dynacat_s);
1861 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_dynacat 1000
1863 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
1865 dynacat_register_finaliser(dynacat_t b)
1867 GC_finalization_proc *foo = NULL;
1869 auto void dynacat_finaliser();
1871 auto void dynacat_finaliser(void *obj, void *SXE_UNUSED(data))
1873 SXE_DEBUG_GC("calling dynacat finaliser on %p\n", obj);
1876 memset(obj, 0, sizeof(struct dynacat_s));
1880 SXE_DEBUG_GC("dynacat-fina %p\n", b);
1881 GC_REGISTER_FINALIZER(b, dynacat_finaliser, NULL, foo, bar);
1886 dynacat_register_finaliser(dynacat_t SXE_UNUSED(b))
1890 #endif /* HAVE_BDWGC */
1893 make_dynacat(void *ptr)
1897 ALLOCATE_FIXED_TYPE(dynacat, struct dynacat_s, emp);
1898 dynacat_register_finaliser(emp);
1899 set_lheader_implementation(&emp->lheader, &lrecord_dynacat);
1902 emp->intprfun = NULL;
1909 return wrap_object(emp);
1913 /************************************************************************/
1914 /* Vector allocation */
1915 /************************************************************************/
1917 static Lisp_Object mark_vector(Lisp_Object obj)
1919 Lisp_Vector *ptr = XVECTOR(obj);
1920 int len = vector_length(ptr);
1923 for (i = 0; i < len - 1; i++)
1924 mark_object(ptr->contents[i]);
1925 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1928 static size_t size_vector(const void *lheader)
1930 return FLEXIBLE_ARRAY_STRUCT_SIZEOF(
1931 Lisp_Vector, Lisp_Object, contents,
1932 ((const Lisp_Vector*)lheader)->size);
1935 static int vector_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
1937 int len = XVECTOR_LENGTH(obj1);
1938 if (len != XVECTOR_LENGTH(obj2))
1942 Lisp_Object *ptr1 = XVECTOR_DATA(obj1);
1943 Lisp_Object *ptr2 = XVECTOR_DATA(obj2);
1945 if (!internal_equal(*ptr1++, *ptr2++, depth + 1))
1951 static hcode_t vector_hash(Lisp_Object obj, int depth)
1953 return HASH2(XVECTOR_LENGTH(obj),
1954 internal_array_hash(XVECTOR_DATA(obj),
1955 XVECTOR_LENGTH(obj), depth + 1));
1958 /* the seq approach for conses */
1960 vec_length(const seq_t v)
1962 return XVECTOR_LENGTH((Lisp_Object)(long int)v);
1966 vec_iter_init(seq_t v, seq_iter_t si)
1969 si->data = (void*)0;
1974 vec_iter_next(seq_iter_t si, void **elt)
1976 if (si->seq != NULL &&
1977 (long int)si->data < ((Lisp_Vector*)si->seq)->size) {
1978 *elt = (void*)vector_data((Lisp_Vector*)si->seq)
1979 [(long int)si->data];
1980 si->data = (void*)((long int)si->data + 1L);
1988 vec_iter_fini(seq_iter_t si)
1990 si->data = si->seq = NULL;
1995 vec_iter_reset(seq_iter_t si)
1997 si->data = (void*)0;
2002 vec_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
2004 size_t len = vector_length((const Lisp_Vector*)s);
2005 volatile size_t i = 0;
2007 while (i < len && i < ntgt) {
2008 tgt[i] = (void*)vector_data((const Lisp_Vector*)s)[i];
2014 static struct seq_impl_s __svec = {
2015 .length_f = vec_length,
2016 .iter_init_f = vec_iter_init,
2017 .iter_next_f = vec_iter_next,
2018 .iter_fini_f = vec_iter_fini,
2019 .iter_reset_f = vec_iter_reset,
2020 .explode_f = vec_explode,
2023 static const struct lrecord_description vector_description[] = {
2024 {XD_LONG, offsetof(Lisp_Vector, size)},
2025 {XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Vector, contents),
2030 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
2031 mark_vector, print_vector, 0,
2035 size_vector, Lisp_Vector);
2037 /* #### should allocate `small' vectors from a frob-block */
2038 static Lisp_Vector *make_vector_internal(size_t sizei)
2040 /* no vector_next */
2041 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Vector, Lisp_Object,
2043 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord(sizem, &lrecord_vector);
2046 p->header.lheader.morphisms = (1<<cat_mk_lc);
2050 Lisp_Object make_vector(size_t length, Lisp_Object object)
2052 Lisp_Vector *vecp = make_vector_internal(length);
2053 Lisp_Object *p = vector_data(vecp);
2060 XSETVECTOR(vector, vecp);
2065 DEFUN("make-vector", Fmake_vector, 2, 2, 0, /*
2066 Return a new vector of length LENGTH, with each element being OBJECT.
2067 See also the function `vector'.
2071 CONCHECK_NATNUM(length);
2072 return make_vector(XINT(length), object);
2075 DEFUN("vector", Fvector, 0, MANY, 0, /*
2076 Return a newly created vector with specified arguments as elements.
2077 Any number of arguments, even zero arguments, are allowed.
2079 (int nargs, Lisp_Object * args))
2081 Lisp_Vector *vecp = make_vector_internal(nargs);
2082 Lisp_Object *p = vector_data(vecp);
2089 XSETVECTOR(vector, vecp);
2094 Lisp_Object vector1(Lisp_Object obj0)
2096 return Fvector(1, &obj0);
2099 Lisp_Object vector2(Lisp_Object obj0, Lisp_Object obj1)
2101 Lisp_Object args[2];
2104 return Fvector(2, args);
2107 Lisp_Object vector3(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
2109 Lisp_Object args[3];
2113 return Fvector(3, args);
2116 #if 0 /* currently unused */
2119 vector4(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
2121 Lisp_Object args[4];
2126 return Fvector(4, args);
2130 vector5(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2131 Lisp_Object obj3, Lisp_Object obj4)
2133 Lisp_Object args[5];
2139 return Fvector(5, args);
2143 vector6(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2144 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
2146 Lisp_Object args[6];
2153 return Fvector(6, args);
2157 vector7(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2158 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5, Lisp_Object obj6)
2160 Lisp_Object args[7];
2168 return Fvector(7, args);
2172 vector8(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2173 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
2174 Lisp_Object obj6, Lisp_Object obj7)
2176 Lisp_Object args[8];
2185 return Fvector(8, args);
2189 /************************************************************************/
2190 /* Bit Vector allocation */
2191 /************************************************************************/
2193 static Lisp_Object all_bit_vectors;
2195 /* #### should allocate `small' bit vectors from a frob-block */
2196 static Lisp_Bit_Vector *make_bit_vector_internal(size_t sizei)
2198 size_t num_longs = BIT_VECTOR_LONG_STORAGE(sizei);
2200 FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Bit_Vector, unsigned long,
2202 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage(sizem);
2203 set_lheader_implementation(&p->lheader, &lrecord_bit_vector);
2205 INCREMENT_CONS_COUNTER(sizem, "bit-vector");
2207 bit_vector_length(p) = sizei;
2208 bit_vector_next(p) = all_bit_vectors;
2209 /* make sure the extra bits in the last long are 0; the calling
2210 functions might not set them. */
2211 p->bits[num_longs - 1] = 0;
2212 XSETBIT_VECTOR(all_bit_vectors, p);
2214 /* propagate seq implementation */
2215 p->lheader.morphisms = 0;
2219 Lisp_Object make_bit_vector(size_t length, Lisp_Object bit)
2221 Lisp_Bit_Vector *p = make_bit_vector_internal(length);
2222 size_t num_longs = BIT_VECTOR_LONG_STORAGE(length);
2227 memset(p->bits, 0, num_longs * sizeof(long));
2229 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
2230 memset(p->bits, ~0, num_longs * sizeof(long));
2231 /* But we have to make sure that the unused bits in the
2232 last long are 0, so that equal/hash is easy. */
2234 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
2238 Lisp_Object bit_vector;
2239 XSETBIT_VECTOR(bit_vector, p);
2245 make_bit_vector_from_byte_vector(unsigned char *bytevec, size_t length)
2248 Lisp_Bit_Vector *p = make_bit_vector_internal(length);
2250 for (i = 0; i < length; i++)
2251 set_bit_vector_bit(p, i, bytevec[i]);
2254 Lisp_Object bit_vector;
2255 XSETBIT_VECTOR(bit_vector, p);
2260 DEFUN("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
2261 Return a new bit vector of length LENGTH. with each bit set to BIT.
2262 BIT must be one of the integers 0 or 1. See also the function `bit-vector'.
2266 CONCHECK_NATNUM(length);
2268 return make_bit_vector(XINT(length), bit);
2271 DEFUN("bit-vector", Fbit_vector, 0, MANY, 0, /*
2272 Return a newly created bit vector with specified arguments as elements.
2273 Any number of arguments, even zero arguments, are allowed.
2274 Each argument must be one of the integers 0 or 1.
2276 (int nargs, Lisp_Object * args))
2279 Lisp_Bit_Vector *p = make_bit_vector_internal(nargs);
2281 for (i = 0; i < nargs; i++) {
2283 set_bit_vector_bit(p, i, !ZEROP(args[i]));
2287 Lisp_Object bit_vector;
2288 XSETBIT_VECTOR(bit_vector, p);
2293 /* the seq approach for conses */
2295 bvc_length(const seq_t bv)
2297 return bit_vector_length(XBIT_VECTOR((Lisp_Object)(long int)bv));
2301 bvc_iter_init(seq_t bv, seq_iter_t si)
2304 si->data = (void*)0;
2309 bvc_iter_next(seq_iter_t si, void **elt)
2311 if (si->seq != NULL &&
2312 (long int)si->data < bit_vector_length((Lisp_Bit_Vector*)si->seq)) {
2313 *elt = (void*)make_int(
2315 (Lisp_Bit_Vector*)si->seq, (size_t)si->data));
2316 si->data = (void*)((long int)si->data + 1L);
2324 bvc_iter_fini(seq_iter_t si)
2326 si->data = si->seq = NULL;
2331 bvc_iter_reset(seq_iter_t si)
2333 si->data = (void*)0;
2338 bvc_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
2340 size_t len = bit_vector_length((const Lisp_Bit_Vector*)s);
2341 volatile size_t i = 0;
2343 while (i < len && i < ntgt) {
2344 tgt[i] = (void*)make_int(
2345 bit_vector_bit((const Lisp_Bit_Vector*)s, i));
2351 static struct seq_impl_s __sbvc = {
2352 .length_f = bvc_length,
2353 .iter_init_f = bvc_iter_init,
2354 .iter_next_f = bvc_iter_next,
2355 .iter_fini_f = bvc_iter_fini,
2356 .iter_reset_f = bvc_iter_reset,
2357 .explode_f = bvc_explode,
2360 /************************************************************************/
2361 /* Compiled-function allocation */
2362 /************************************************************************/
2364 DECLARE_FIXED_TYPE_ALLOC(compiled_function, Lisp_Compiled_Function);
2365 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
2367 static Lisp_Object make_compiled_function(void)
2369 Lisp_Compiled_Function *f;
2372 ALLOCATE_FIXED_TYPE(compiled_function, Lisp_Compiled_Function, f);
2373 set_lheader_implementation(&f->lheader, &lrecord_compiled_function);
2376 f->specpdl_depth = 0;
2377 f->flags.documentationp = 0;
2378 f->flags.interactivep = 0;
2379 f->flags.domainp = 0; /* I18N3 */
2380 f->instructions = Qzero;
2381 f->constants = Qzero;
2383 f->doc_and_interactive = Qnil;
2384 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2385 f->annotated = Qnil;
2387 XSETCOMPILED_FUNCTION(fun, f);
2391 DEFUN("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
2392 Return a new compiled-function object.
2393 Usage: (arglist instructions constants stack-depth
2394 &optional doc-string interactive)
2395 Note that, unlike all other emacs-lisp functions, calling this with five
2396 arguments is NOT the same as calling it with six arguments, the last of
2397 which is nil. If the INTERACTIVE arg is specified as nil, then that means
2398 that this function was defined with `(interactive)'. If the arg is not
2399 specified, then that means the function is not interactive.
2400 This is terrible behavior which is retained for compatibility with old
2401 `.elc' files which expect these semantics.
2403 (int nargs, Lisp_Object * args))
2405 /* In a non-insane world this function would have this arglist...
2406 (arglist instructions constants stack_depth &optional doc_string interactive)
2408 Lisp_Object fun = make_compiled_function();
2409 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(fun);
2411 Lisp_Object arglist = args[0];
2412 Lisp_Object instructions = args[1];
2413 Lisp_Object constants = args[2];
2414 Lisp_Object stack_depth = args[3];
2415 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
2416 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
2418 if (nargs < 4 || nargs > 6)
2419 return Fsignal(Qwrong_number_of_arguments,
2420 list2(intern("make-byte-code"),
2423 /* Check for valid formal parameter list now, to allow us to use
2424 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
2426 EXTERNAL_LIST_LOOP_3(symbol, arglist, tail) {
2427 CHECK_SYMBOL(symbol);
2428 if (EQ(symbol, Qt) ||
2429 EQ(symbol, Qnil) || SYMBOL_IS_KEYWORD(symbol))
2430 signal_simple_error_2
2431 ("Invalid constant symbol in formal parameter list",
2435 f->arglist = arglist;
2437 /* `instructions' is a string or a cons (string . int) for a
2438 lazy-loaded function. */
2439 if (CONSP(instructions)) {
2440 CHECK_STRING(XCAR(instructions));
2441 CHECK_INT(XCDR(instructions));
2443 CHECK_STRING(instructions);
2445 f->instructions = instructions;
2447 if (!NILP(constants))
2448 CHECK_VECTOR(constants);
2449 f->constants = constants;
2451 CHECK_NATNUM(stack_depth);
2452 f->stack_depth = (unsigned short)XINT(stack_depth);
2454 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2455 if (!NILP(Vcurrent_compiled_function_annotation))
2456 f->annotated = Fcopy(Vcurrent_compiled_function_annotation);
2457 else if (!NILP(Vload_file_name_internal_the_purecopy))
2458 f->annotated = Vload_file_name_internal_the_purecopy;
2459 else if (!NILP(Vload_file_name_internal)) {
2460 struct gcpro gcpro1;
2461 GCPRO1(fun); /* don't let fun get reaped */
2462 Vload_file_name_internal_the_purecopy =
2463 Ffile_name_nondirectory(Vload_file_name_internal);
2464 f->annotated = Vload_file_name_internal_the_purecopy;
2467 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2469 /* doc_string may be nil, string, int, or a cons (string . int).
2470 interactive may be list or string (or unbound). */
2471 f->doc_and_interactive = Qunbound;
2473 if ((f->flags.domainp = !NILP(Vfile_domain)) != 0)
2474 f->doc_and_interactive = Vfile_domain;
2476 if ((f->flags.interactivep = !UNBOUNDP(interactive)) != 0) {
2477 f->doc_and_interactive
2478 = (UNBOUNDP(f->doc_and_interactive) ? interactive :
2479 Fcons(interactive, f->doc_and_interactive));
2481 if ((f->flags.documentationp = !NILP(doc_string)) != 0) {
2482 f->doc_and_interactive
2483 = (UNBOUNDP(f->doc_and_interactive) ? doc_string :
2484 Fcons(doc_string, f->doc_and_interactive));
2486 if (UNBOUNDP(f->doc_and_interactive))
2487 f->doc_and_interactive = Qnil;
2492 /************************************************************************/
2493 /* Symbol allocation */
2494 /************************************************************************/
2496 DECLARE_FIXED_TYPE_ALLOC(symbol, Lisp_Symbol);
2497 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
2499 DEFUN("make-symbol", Fmake_symbol, 1, 1, 0, /*
2500 Return a newly allocated uninterned symbol whose name is NAME.
2501 Its value and function definition are void, and its property list is nil.
2510 ALLOCATE_FIXED_TYPE(symbol, Lisp_Symbol, p);
2511 set_lheader_implementation(&p->lheader, &lrecord_symbol);
2512 p->name = XSTRING(name);
2514 p->value = Qunbound;
2515 p->function = Qunbound;
2521 /************************************************************************/
2522 /* Extent allocation */
2523 /************************************************************************/
2525 DECLARE_FIXED_TYPE_ALLOC(extent, struct extent);
2526 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
2528 struct extent *allocate_extent(void)
2532 ALLOCATE_FIXED_TYPE(extent, struct extent, e);
2533 set_lheader_implementation(&e->lheader, &lrecord_extent);
2534 extent_object(e) = Qnil;
2535 set_extent_start(e, -1);
2536 set_extent_end(e, -1);
2541 extent_face(e) = Qnil;
2542 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
2543 e->flags.detachable = 1;
2548 /************************************************************************/
2549 /* Event allocation */
2550 /************************************************************************/
2552 DECLARE_FIXED_TYPE_ALLOC(event, Lisp_Event);
2553 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
2555 Lisp_Object allocate_event(void)
2560 ALLOCATE_FIXED_TYPE(event, Lisp_Event, e);
2561 set_lheader_implementation(&e->lheader, &lrecord_event);
2567 /************************************************************************/
2568 /* Marker allocation */
2569 /************************************************************************/
2571 DECLARE_FIXED_TYPE_ALLOC(marker, Lisp_Marker);
2572 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
2574 DEFUN("make-marker", Fmake_marker, 0, 0, 0, /*
2575 Return a new marker which does not point at any place.
2582 ALLOCATE_FIXED_TYPE(marker, Lisp_Marker, p);
2583 set_lheader_implementation(&p->lheader, &lrecord_marker);
2588 p->insertion_type = 0;
2593 Lisp_Object noseeum_make_marker(void)
2598 NOSEEUM_ALLOCATE_FIXED_TYPE(marker, Lisp_Marker, p);
2599 set_lheader_implementation(&p->lheader, &lrecord_marker);
2604 p->insertion_type = 0;
2609 /************************************************************************/
2610 /* String allocation */
2611 /************************************************************************/
2613 /* The data for "short" strings generally resides inside of structs of type
2614 string_chars_block. The Lisp_String structure is allocated just like any
2615 other Lisp object (except for vectors), and these are freelisted when
2616 they get garbage collected. The data for short strings get compacted,
2617 but the data for large strings do not.
2619 Previously Lisp_String structures were relocated, but this caused a lot
2620 of bus-errors because the C code didn't include enough GCPRO's for
2621 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
2622 that the reference would get relocated).
2624 This new method makes things somewhat bigger, but it is MUCH safer. */
2626 DECLARE_FIXED_TYPE_ALLOC(string, Lisp_String);
2627 /* strings are used and freed quite often */
2628 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
2629 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
2631 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
2633 string_register_finaliser(Lisp_String *s)
2635 GC_finalization_proc *foo = NULL;
2637 auto void string_finaliser();
2639 auto void string_finaliser(void *obj, void *SXE_UNUSED(data))
2641 if (!(((Lisp_String*)obj)->lheader.c_readonly)) {
2642 yfree(((Lisp_String*)obj)->data);
2645 memset(obj, 0, sizeof(Lisp_String));
2649 SXE_DEBUG_GC("string-fina %p\n", s);
2650 GC_REGISTER_FINALIZER(s, string_finaliser, NULL, foo, bar);
2655 string_register_finaliser(Lisp_String *SXE_UNUSED(b))
2659 #endif /* HAVE_BDWGC */
2661 static Lisp_Object mark_string(Lisp_Object obj)
2663 Lisp_String *ptr = XSTRING(obj);
2665 if (CONSP(ptr->plist) && EXTENT_INFOP(XCAR(ptr->plist)))
2666 flush_cached_extent_info(XCAR(ptr->plist));
2667 #ifdef EF_USE_COMPRE
2668 mark_object(ptr->compre);
2673 static int string_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
2676 return (((len = XSTRING_LENGTH(obj1)) == XSTRING_LENGTH(obj2)) &&
2677 !memcmp(XSTRING_DATA(obj1), XSTRING_DATA(obj2), len));
2680 static const struct lrecord_description string_description[] = {
2681 {XD_BYTECOUNT, offsetof(Lisp_String, size)},
2682 {XD_OPAQUE_DATA_PTR, offsetof(Lisp_String, data), XD_INDIRECT(0, 1)},
2683 #ifdef EF_USE_COMPRE
2684 {XD_LISP_OBJECT, offsetof(Lisp_String, compre)},
2686 {XD_LISP_OBJECT, offsetof(Lisp_String, plist)},
2690 /* the seq implementation */
2692 str_length(const seq_t str)
2694 return string_char_length((const Lisp_String*)str);
2698 str_iter_init(seq_t str, seq_iter_t si)
2701 si->data = (void*)0;
2706 str_iter_next(seq_iter_t si, void **elt)
2708 if (si->seq != NULL &&
2709 (long int)si->data < string_char_length((Lisp_String*)si->seq)) {
2710 *elt = (void*)make_char(
2711 string_char((Lisp_String*)si->seq, (long int)si->data));
2712 si->data = (void*)((long int)si->data + 1);
2720 str_iter_fini(seq_iter_t si)
2722 si->data = si->seq = NULL;
2727 str_iter_reset(seq_iter_t si)
2729 si->data = (void*)0;
2734 str_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
2736 size_t len = string_char_length((const Lisp_String*)s);
2737 volatile size_t i = 0;
2739 while (i < len && i < ntgt) {
2740 tgt[i] = (void*)make_char(string_char((Lisp_String*)s, i));
2746 static struct seq_impl_s __sstr = {
2747 .length_f = str_length,
2748 .iter_init_f = str_iter_init,
2749 .iter_next_f = str_iter_next,
2750 .iter_fini_f = str_iter_fini,
2751 .iter_reset_f = str_iter_reset,
2752 .explode_f = str_explode,
2756 /* We store the string's extent info as the first element of the string's
2757 property list; and the string's MODIFF as the first or second element
2758 of the string's property list (depending on whether the extent info
2759 is present), but only if the string has been modified. This is ugly
2760 but it reduces the memory allocated for the string in the vast
2761 majority of cases, where the string is never modified and has no
2764 #### This means you can't use an int as a key in a string's plist. */
2766 static Lisp_Object *string_plist_ptr(Lisp_Object string)
2768 Lisp_Object *ptr = &XSTRING(string)->plist;
2770 if (CONSP(*ptr) && EXTENT_INFOP(XCAR(*ptr)))
2772 if (CONSP(*ptr) && INTP(XCAR(*ptr)))
2777 static Lisp_Object string_getprop(Lisp_Object string, Lisp_Object property)
2779 return external_plist_get(string_plist_ptr(string), property, 0,
2784 string_putprop(Lisp_Object string, Lisp_Object property, Lisp_Object value)
2786 external_plist_put(string_plist_ptr(string), property, value, 0,
2791 static int string_remprop(Lisp_Object string, Lisp_Object property)
2793 return external_remprop(string_plist_ptr(string), property, 0,
2797 static Lisp_Object string_plist(Lisp_Object string)
2799 return *string_plist_ptr(string);
2802 /* No `finalize', or `hash' methods.
2803 internal_hash() already knows how to hash strings and finalization
2804 is done with the ADDITIONAL_FREE_string macro, which is the
2805 standard way to do finalization when using
2806 SWEEP_FIXED_TYPE_BLOCK(). */
2807 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS("string", string,
2808 mark_string, print_string,
2814 string_plist, Lisp_String);
2816 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2817 /* String blocks contain this many useful bytes. */
2818 #define STRING_CHARS_BLOCK_SIZE \
2819 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
2820 ((2 * sizeof (struct string_chars_block *)) \
2821 + sizeof (EMACS_INT))))
2822 /* Block header for small strings. */
2823 struct string_chars_block {
2825 struct string_chars_block *next;
2826 struct string_chars_block *prev;
2827 /* Contents of string_chars_block->string_chars are interleaved
2828 string_chars structures (see below) and the actual string data */
2829 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
2832 static struct string_chars_block *first_string_chars_block;
2833 static struct string_chars_block *current_string_chars_block;
2835 /* If SIZE is the length of a string, this returns how many bytes
2836 * the string occupies in string_chars_block->string_chars
2837 * (including alignment padding).
2839 #define STRING_FULLSIZE(size) \
2840 ALIGN_SIZE(((size) + 1 + sizeof(Lisp_String*)), ALIGNOF(Lisp_String*))
2842 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
2843 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
2845 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL)
2846 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL))
2848 struct string_chars {
2849 Lisp_String *string;
2850 unsigned char chars[1];
2853 struct unused_string_chars {
2854 Lisp_String *string;
2858 static void init_string_chars_alloc(void)
2860 first_string_chars_block = ynew(struct string_chars_block);
2861 first_string_chars_block->prev = 0;
2862 first_string_chars_block->next = 0;
2863 first_string_chars_block->pos = 0;
2864 current_string_chars_block = first_string_chars_block;
2867 static struct string_chars*
2868 allocate_string_chars_struct(Lisp_String *string_it_goes_with,
2871 struct string_chars *s_chars;
2873 if (fullsize <= (countof(current_string_chars_block->string_chars)
2874 - current_string_chars_block->pos)) {
2875 /* This string can fit in the current string chars block */
2876 s_chars = (struct string_chars *)
2877 (current_string_chars_block->string_chars
2878 + current_string_chars_block->pos);
2879 current_string_chars_block->pos += fullsize;
2881 /* Make a new current string chars block */
2882 struct string_chars_block *new_scb =
2883 ynew(struct string_chars_block);
2885 current_string_chars_block->next = new_scb;
2886 new_scb->prev = current_string_chars_block;
2888 current_string_chars_block = new_scb;
2889 new_scb->pos = fullsize;
2890 s_chars = (struct string_chars *)
2891 current_string_chars_block->string_chars;
2894 s_chars->string = string_it_goes_with;
2896 INCREMENT_CONS_COUNTER(fullsize, "string chars");
2902 Lisp_Object make_uninit_string(Bytecount length)
2904 Lisp_String *s = NULL;
2905 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2906 EMACS_INT fullsize = STRING_FULLSIZE(length);
2910 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2911 assert(length >= 0 && fullsize > 0);
2914 /* Allocate the string header */
2915 ALLOCATE_FIXED_TYPE(string, Lisp_String, s);
2916 set_lheader_implementation(&s->lheader, &lrecord_string);
2917 string_register_finaliser(s);
2920 Bufbyte *foo = NULL;
2921 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
2922 foo = xnew_atomic_array(Bufbyte, length+1);
2923 assert(foo != NULL);
2925 if (BIG_STRING_FULLSIZE_P(fullsize)) {
2926 foo = xnew_atomic_array(Bufbyte, length + 1);
2927 assert(foo != NULL);
2929 foo = allocate_string_chars_struct(s, fullsize)->chars;
2930 assert(foo != NULL);
2933 set_string_data(s, foo);
2935 set_string_length(s, length);
2937 #ifdef EF_USE_COMPRE
2940 /* propagate the cat system, go with the standard impl of a seq first */
2941 s->lheader.morphisms = 0;
2943 set_string_byte(s, length, 0);
2949 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2950 static void verify_string_chars_integrity(void);
2953 /* Resize the string S so that DELTA bytes can be inserted starting
2954 at POS. If DELTA < 0, it means deletion starting at POS. If
2955 POS < 0, resize the string but don't copy any characters. Use
2956 this if you're planning on completely overwriting the string.
2959 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
2960 void resize_string(Lisp_String * s, Bytecount pos, Bytecount delta)
2965 /* trivial cases first */
2967 /* simplest case: no size change. */
2971 if (pos >= 0 && delta < 0) {
2972 /* If DELTA < 0, the functions below will delete the characters
2973 before POS. We want to delete characters *after* POS,
2974 however, so convert this to the appropriate form. */
2978 /* Both strings are big. We can just realloc().
2979 But careful! If the string is shrinking, we have to
2980 memmove() _before_ realloc(), and if growing, we have to
2981 memmove() _after_ realloc() - otherwise the access is
2982 illegal, and we might crash. */
2983 len = string_length(s) + 1 - pos;
2985 if (delta < 0 && pos >= 0) {
2986 memmove(string_data(s) + pos + delta,
2987 string_data(s) + pos, len);
2990 /* do the reallocation */
2991 foo = xrealloc(string_data(s), string_length(s) + delta + 1);
2992 set_string_data(s, foo);
2994 if (delta > 0 && pos >= 0) {
2995 memmove(string_data(s) + pos + delta,
2996 string_data(s) + pos, len);
2999 set_string_length(s, string_length(s) + delta);
3000 /* If pos < 0, the string won't be zero-terminated.
3001 Terminate now just to make sure. */
3002 string_data(s)[string_length(s)] = '\0';
3007 XSETSTRING(string, s);
3008 /* We also have to adjust all of the extent indices after the
3009 place we did the change. We say "pos - 1" because
3010 adjust_extents() is exclusive of the starting position
3012 adjust_extents(string, pos - 1, string_length(s), delta);
3016 #else /* !HAVE_BDWGC */
3017 void resize_string(Lisp_String * s, Bytecount pos, Bytecount delta)
3019 Bytecount oldfullsize, newfullsize;
3020 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3021 verify_string_chars_integrity();
3024 #ifdef ERROR_CHECK_BUFPOS
3026 assert(pos <= string_length(s));
3028 assert(pos + (-delta) <= string_length(s));
3031 assert((-delta) <= string_length(s));
3033 #endif /* ERROR_CHECK_BUFPOS */
3036 /* simplest case: no size change. */
3039 if (pos >= 0 && delta < 0)
3040 /* If DELTA < 0, the functions below will delete the characters
3041 before POS. We want to delete characters *after* POS, however,
3042 so convert this to the appropriate form. */
3045 oldfullsize = STRING_FULLSIZE(string_length(s));
3046 newfullsize = STRING_FULLSIZE(string_length(s) + delta);
3048 if (BIG_STRING_FULLSIZE_P(oldfullsize)) {
3049 if (BIG_STRING_FULLSIZE_P(newfullsize)) {
3050 /* Both strings are big. We can just realloc().
3051 But careful! If the string is shrinking, we have to
3052 memmove() _before_ realloc(), and if growing, we have to
3053 memmove() _after_ realloc() - otherwise the access is
3054 illegal, and we might crash. */
3055 Bytecount len = string_length(s) + 1 - pos;
3058 if (delta < 0 && pos >= 0)
3059 memmove(string_data(s) + pos + delta,
3060 string_data(s) + pos, len);
3062 foo = xrealloc(string_data(s),
3063 string_length(s) + delta + 1);
3064 set_string_data(s, foo);
3065 if (delta > 0 && pos >= 0) {
3066 memmove(string_data(s) + pos + delta,
3067 string_data(s) + pos, len);
3070 /* String has been demoted from BIG_STRING. */
3073 allocate_string_chars_struct(s, newfullsize)
3075 Bufbyte *old_data = string_data(s);
3078 memcpy(new_data, old_data, pos);
3079 memcpy(new_data + pos + delta, old_data + pos,
3080 string_length(s) + 1 - pos);
3082 set_string_data(s, new_data);
3085 } else { /* old string is small */
3087 if (oldfullsize == newfullsize) {
3088 /* special case; size change but the necessary
3089 allocation size won't change (up or down; code
3090 somewhere depends on there not being any unused
3091 allocation space, modulo any alignment
3094 Bufbyte *addroff = pos + string_data(s);
3096 memmove(addroff + delta, addroff,
3097 /* +1 due to zero-termination. */
3098 string_length(s) + 1 - pos);
3101 Bufbyte *old_data = string_data(s);
3102 Bufbyte *new_data = BIG_STRING_FULLSIZE_P(newfullsize)
3103 ? xnew_atomic_array(
3104 Bufbyte, string_length(s) + delta + 1)
3105 : allocate_string_chars_struct(
3106 s, newfullsize)->chars;
3109 memcpy(new_data, old_data, pos);
3110 memcpy(new_data + pos + delta, old_data + pos,
3111 string_length(s) + 1 - pos);
3113 set_string_data(s, new_data);
3116 /* We need to mark this chunk of the
3117 string_chars_block as unused so that
3118 compact_string_chars() doesn't freak. */
3119 struct string_chars *old_s_chars =
3120 (struct string_chars *)
3122 offsetof(struct string_chars, chars));
3123 /* Sanity check to make sure we aren't hosed by
3124 strange alignment/padding. */
3125 assert(old_s_chars->string == s);
3126 MARK_STRING_CHARS_AS_FREE(old_s_chars);
3127 ((struct unused_string_chars *)old_s_chars)->
3128 fullsize = oldfullsize;
3133 set_string_length(s, string_length(s) + delta);
3134 /* If pos < 0, the string won't be zero-terminated.
3135 Terminate now just to make sure. */
3136 string_data(s)[string_length(s)] = '\0';
3141 XSETSTRING(string, s);
3142 /* We also have to adjust all of the extent indices after the
3143 place we did the change. We say "pos - 1" because
3144 adjust_extents() is exclusive of the starting position
3146 adjust_extents(string, pos - 1, string_length(s), delta);
3148 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3149 verify_string_chars_integrity();
3155 void set_string_char(Lisp_String * s, Charcount i, Emchar c)
3157 Bufbyte newstr[MAX_EMCHAR_LEN];
3158 Bytecount bytoff = charcount_to_bytecount(string_data(s), i);
3159 Bytecount oldlen = charcount_to_bytecount(string_data(s) + bytoff, 1);
3160 Bytecount newlen = set_charptr_emchar(newstr, c);
3162 if (oldlen != newlen) {
3163 resize_string(s, bytoff, newlen - oldlen);
3165 /* Remember, string_data (s) might have changed so we can't cache it. */
3166 memcpy(string_data(s) + bytoff, newstr, newlen);
3171 DEFUN("make-string", Fmake_string, 2, 2, 0, /*
3172 Return a new string consisting of LENGTH copies of CHARACTER.
3173 LENGTH must be a non-negative integer.
3175 (length, character))
3177 CHECK_NATNUM(length);
3178 CHECK_CHAR_COERCE_INT(character);
3180 Bufbyte init_str[MAX_EMCHAR_LEN];
3181 int len = set_charptr_emchar(init_str, XCHAR(character));
3182 Lisp_Object val = make_uninit_string(len * XINT(length));
3185 /* Optimize the single-byte case */
3186 memset(XSTRING_DATA(val), XCHAR(character),
3187 XSTRING_LENGTH(val));
3190 Bufbyte *ptr = XSTRING_DATA(val);
3192 for (i = XINT(length); i; i--) {
3193 Bufbyte *init_ptr = init_str;
3196 *ptr++ = *init_ptr++;
3198 *ptr++ = *init_ptr++;
3200 *ptr++ = *init_ptr++;
3202 *ptr++ = *init_ptr++;
3212 DEFUN("string", Fstring, 0, MANY, 0, /*
3213 Concatenate all the argument characters and make the result a string.
3215 (int nargs, Lisp_Object * args))
3217 Bufbyte *storage, *p;
3219 int speccount = specpdl_depth();
3220 int len = nargs * MAX_EMCHAR_LEN;
3222 XMALLOC_OR_ALLOCA(storage, len, Bufbyte);
3224 for (; nargs; nargs--, args++) {
3225 Lisp_Object lisp_char = *args;
3226 CHECK_CHAR_COERCE_INT(lisp_char);
3227 p += set_charptr_emchar(p, XCHAR(lisp_char));
3229 result = make_string(storage, p - storage);
3230 XMALLOC_UNBIND(storage, len, speccount );
3235 /* Take some raw memory, which MUST already be in internal format,
3236 and package it up into a Lisp string. */
3238 make_string(const Bufbyte *contents, Bytecount length)
3242 /* Make sure we find out about bad make_string's when they happen */
3243 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
3244 /* Just for the assertions */
3245 bytecount_to_charcount(contents, length);
3248 val = make_uninit_string(length);
3249 memcpy(XSTRING_DATA(val), contents, length);
3253 /* Take some raw memory, encoded in some external data format,
3254 and convert it into a Lisp string. */
3256 make_ext_string(const Extbyte *contents, EMACS_INT length,
3257 Lisp_Object coding_system)
3260 TO_INTERNAL_FORMAT(DATA, (contents, length),
3261 LISP_STRING, string, coding_system);
3265 /* why arent the next 3 inlines? */
3266 Lisp_Object build_string(const char *str)
3268 /* Some strlen's crash and burn if passed null. */
3270 return make_string((const Bufbyte*)str, strlen(str));
3276 Lisp_Object build_ext_string(const char *str, Lisp_Object coding_system)
3278 /* Some strlen's crash and burn if passed null. */
3279 return make_ext_string((const Extbyte*)str, (str ? strlen(str) : 0), coding_system);
3282 Lisp_Object build_translated_string(const char *str)
3284 return build_string(GETTEXT(str));
3287 Lisp_Object make_string_nocopy(Bufbyte *contents, Bytecount length)
3292 /* Make sure we find out about bad make_string_nocopy's when they
3294 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
3295 /* Just for the assertions */
3296 bytecount_to_charcount(contents, length);
3299 /* Allocate the string header */
3300 ALLOCATE_FIXED_TYPE(string, Lisp_String, s);
3301 set_lheader_implementation(&s->lheader, &lrecord_string);
3302 SET_C_READONLY_RECORD_HEADER(&s->lheader);
3303 string_register_finaliser(s);
3306 #ifdef EF_USE_COMPRE
3309 set_string_data(s, (Bufbyte*)contents);
3310 set_string_length(s, length);
3316 /************************************************************************/
3317 /* lcrecord lists */
3318 /************************************************************************/
3320 /* Lcrecord lists are used to manage the allocation of particular
3321 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
3322 malloc() and garbage-collection junk) as much as possible.
3323 It is similar to the Blocktype class.
3327 1) Create an lcrecord-list object using make_lcrecord_list().
3328 This is often done at initialization. Remember to staticpro_nodump
3329 this object! The arguments to make_lcrecord_list() are the
3330 same as would be passed to alloc_lcrecord().
3331 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
3332 and pass the lcrecord-list earlier created.
3333 3) When done with the lcrecord, call free_managed_lcrecord().
3334 The standard freeing caveats apply: ** make sure there are no
3335 pointers to the object anywhere! **
3336 4) Calling free_managed_lcrecord() is just like kissing the
3337 lcrecord goodbye as if it were garbage-collected. This means:
3338 -- the contents of the freed lcrecord are undefined, and the
3339 contents of something produced by allocate_managed_lcrecord()
3340 are undefined, just like for alloc_lcrecord().
3341 -- the mark method for the lcrecord's type will *NEVER* be called
3343 -- the finalize method for the lcrecord's type will be called
3344 at the time that free_managed_lcrecord() is called.
3346 lcrecord lists do not work in bdwgc mode. -hrop
3350 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3352 mark_lcrecord_list(Lisp_Object obj)
3357 /* just imitate the lcrecord spectactular */
3359 make_lcrecord_list(size_t size,
3360 const struct lrecord_implementation *implementation)
3362 struct lcrecord_list *p =
3363 alloc_lcrecord_type(struct lcrecord_list,
3364 &lrecord_lcrecord_list);
3367 p->implementation = implementation;
3370 XSETLCRECORD_LIST(val, p);
3375 allocate_managed_lcrecord(Lisp_Object lcrecord_list)
3377 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3378 void *tmp = alloc_lcrecord(list->size, list->implementation);
3386 free_managed_lcrecord(Lisp_Object SXE_UNUSED(lcrecord_list), Lisp_Object lcrecord)
3388 struct free_lcrecord_header *free_header =
3389 (struct free_lcrecord_header*)XPNTR(lcrecord);
3390 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3391 const struct lrecord_implementation *imp =
3392 LHEADER_IMPLEMENTATION(lheader);
3394 if (imp->finalizer) {
3395 imp->finalizer(lheader, 0);
3403 mark_lcrecord_list(Lisp_Object obj)
3405 struct lcrecord_list *list = XLCRECORD_LIST(obj);
3406 Lisp_Object chain = list->free;
3408 while (!NILP(chain)) {
3409 struct lrecord_header *lheader = XRECORD_LHEADER(chain);
3410 struct free_lcrecord_header *free_header =
3411 (struct free_lcrecord_header *)lheader;
3414 /* There should be no other pointers to the free list. */
3415 !MARKED_RECORD_HEADER_P(lheader)
3417 /* Only lcrecords should be here. */
3418 !LHEADER_IMPLEMENTATION(lheader)->
3420 /* Only free lcrecords should be here. */
3421 free_header->lcheader.free &&
3422 /* The type of the lcrecord must be right. */
3423 LHEADER_IMPLEMENTATION(lheader) ==
3424 list->implementation &&
3425 /* So must the size. */
3426 (LHEADER_IMPLEMENTATION(lheader)->
3428 || LHEADER_IMPLEMENTATION(lheader)->
3429 static_size == list->size)
3432 MARK_RECORD_HEADER(lheader);
3433 chain = free_header->chain;
3440 make_lcrecord_list(size_t size,
3441 const struct lrecord_implementation *implementation)
3443 struct lcrecord_list *p =
3444 alloc_lcrecord_type(struct lcrecord_list,
3445 &lrecord_lcrecord_list);
3448 p->implementation = implementation;
3451 XSETLCRECORD_LIST(val, p);
3456 allocate_managed_lcrecord(Lisp_Object lcrecord_list)
3458 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3459 if (!NILP(list->free)) {
3460 Lisp_Object val = list->free;
3461 struct free_lcrecord_header *free_header =
3462 (struct free_lcrecord_header *)XPNTR(val);
3464 #ifdef ERROR_CHECK_GC
3465 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3467 /* There should be no other pointers to the free list. */
3468 assert(!MARKED_RECORD_HEADER_P(lheader));
3469 /* Only lcrecords should be here. */
3470 assert(!LHEADER_IMPLEMENTATION(lheader)->basic_p);
3471 /* Only free lcrecords should be here. */
3472 assert(free_header->lcheader.free);
3473 /* The type of the lcrecord must be right. */
3474 assert(LHEADER_IMPLEMENTATION(lheader) == list->implementation);
3475 /* So must the size. */
3476 assert(LHEADER_IMPLEMENTATION(lheader)->static_size == 0 ||
3477 LHEADER_IMPLEMENTATION(lheader)->static_size ==
3479 #endif /* ERROR_CHECK_GC */
3481 list->free = free_header->chain;
3482 free_header->lcheader.free = 0;
3485 void *tmp = alloc_lcrecord(list->size, list->implementation);
3494 free_managed_lcrecord(Lisp_Object lcrecord_list, Lisp_Object lcrecord)
3496 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3497 struct free_lcrecord_header *free_header =
3498 (struct free_lcrecord_header*)XPNTR(lcrecord);
3499 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3500 const struct lrecord_implementation *implementation
3501 = LHEADER_IMPLEMENTATION(lheader);
3503 /* Make sure the size is correct. This will catch, for example,
3504 putting a window configuration on the wrong free list. */
3505 gc_checking_assert((implementation->size_in_bytes_method ?
3506 implementation->size_in_bytes_method(lheader) :
3507 implementation->static_size)
3510 if (implementation->finalizer) {
3511 implementation->finalizer(lheader, 0);
3513 free_header->chain = list->free;
3514 free_header->lcheader.free = 1;
3515 list->free = lcrecord;
3519 DEFINE_LRECORD_IMPLEMENTATION("lcrecord-list", lcrecord_list,
3520 mark_lcrecord_list, internal_object_printer,
3521 0, 0, 0, 0, struct lcrecord_list);
3524 DEFUN("purecopy", Fpurecopy, 1, 1, 0, /*
3525 Kept for compatibility, returns its argument.
3527 Make a copy of OBJECT in pure storage.
3528 Recursively copies contents of vectors and cons cells.
3529 Does not copy symbols.
3536 /************************************************************************/
3537 /* Garbage Collection */
3538 /************************************************************************/
3540 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
3541 Additional ones may be defined by a module (none yet). We leave some
3542 room in `lrecord_implementations_table' for such new lisp object types. */
3543 const struct lrecord_implementation
3544 *lrecord_implementations_table[(unsigned int)lrecord_type_last_built_in_type
3545 + MODULE_DEFINABLE_TYPE_COUNT];
3546 unsigned int lrecord_type_count = (unsigned int)lrecord_type_last_built_in_type;
3547 /* Object marker functions are in the lrecord_implementation structure.
3548 But copying them to a parallel array is much more cache-friendly.
3549 This hack speeds up (garbage-collect) by about 5%. */
3550 Lisp_Object(*lrecord_markers[countof(lrecord_implementations_table)])
3553 #ifndef EF_USE_ASYNEQ
3554 struct gcpro *gcprolist;
3557 /* We want the staticpros relocated, but not the pointers found therein.
3558 Hence we use a trivial description, as for pointerless objects. */
3559 static const struct lrecord_description staticpro_description_1[] = {
3563 static const struct struct_description staticpro_description = {
3564 sizeof(Lisp_Object *),
3565 staticpro_description_1
3568 static const struct lrecord_description staticpros_description_1[] = {
3569 XD_DYNARR_DESC(Lisp_Object_ptr_dynarr, &staticpro_description),
3573 static const struct struct_description staticpros_description = {
3574 sizeof(Lisp_Object_ptr_dynarr),
3575 staticpros_description_1
3578 Lisp_Object_ptr_dynarr *staticpros;
3580 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
3581 garbage collection, and for dumping. */
3582 void staticpro(Lisp_Object * varaddress)
3585 Dynarr_add(staticpros, varaddress);
3586 dump_add_root_object(varaddress);
3590 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3591 Lisp_Object_ptr_dynarr *staticpros_nodump;
3593 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
3594 garbage collection, but not for dumping. */
3595 void staticpro_nodump(Lisp_Object * varaddress)
3598 Dynarr_add(staticpros_nodump, varaddress);
3604 #ifdef ERROR_CHECK_GC
3605 #define GC_CHECK_LHEADER_INVARIANTS(lheader) \
3607 struct lrecord_header * GCLI_lh = (lheader); \
3608 assert (GCLI_lh != 0); \
3609 assert (GCLI_lh->type < lrecord_type_count); \
3610 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
3611 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
3612 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
3615 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
3618 /* Mark reference to a Lisp_Object. If the object referred to has not been
3619 seen yet, recursively mark all the references contained in it. */
3621 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3622 void mark_object(Lisp_Object SXE_UNUSED(obj))
3628 void mark_object(Lisp_Object obj)
3630 if (obj == Qnull_pointer) {
3635 /* Checks we used to perform */
3636 /* if (EQ (obj, Qnull_pointer)) return; */
3637 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
3638 /* if (PURIFIED (XPNTR (obj))) return; */
3640 if (XTYPE(obj) == Lisp_Type_Record) {
3641 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
3643 GC_CHECK_LHEADER_INVARIANTS(lheader);
3645 gc_checking_assert(LHEADER_IMPLEMENTATION(lheader)->basic_p ||
3646 !((struct lcrecord_header *)lheader)->free);
3648 /* All c_readonly objects have their mark bit set,
3649 so that we only need to check the mark bit here. */
3650 if (!MARKED_RECORD_HEADER_P(lheader)) {
3651 MARK_RECORD_HEADER(lheader);
3653 if (RECORD_MARKER(lheader)) {
3654 obj = RECORD_MARKER(lheader) (obj);
3663 /* mark all of the conses in a list and mark the final cdr; but
3664 DO NOT mark the cars.
3666 Use only for internal lists! There should never be other pointers
3667 to the cons cells, because if so, the cars will remain unmarked
3668 even when they maybe should be marked. */
3669 void mark_conses_in_list(Lisp_Object obj)
3673 for (rest = obj; CONSP(rest); rest = XCDR(rest)) {
3674 if (CONS_MARKED_P(XCONS(rest)))
3676 MARK_CONS(XCONS(rest));
3682 /* Find all structures not marked, and free them. */
3684 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3685 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
3686 static int gc_count_bit_vector_storage;
3687 static int gc_count_num_short_string_in_use;
3688 static int gc_count_string_total_size;
3689 static int gc_count_short_string_total_size;
3692 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3694 /* stats on lcrecords in use - kinda kludgy */
3696 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3698 int instances_in_use;
3700 int instances_freed;
3702 int instances_on_free_list;
3703 } lcrecord_stats[countof(lrecord_implementations_table)
3704 + MODULE_DEFINABLE_TYPE_COUNT];
3707 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3708 static void tick_lcrecord_stats(const struct lrecord_header *h, int free_p)
3710 unsigned int type_index = h->type;
3712 if (((const struct lcrecord_header *)h)->free) {
3713 gc_checking_assert(!free_p);
3714 lcrecord_stats[type_index].instances_on_free_list++;
3716 const struct lrecord_implementation *implementation =
3717 LHEADER_IMPLEMENTATION(h);
3719 size_t sz = (implementation->size_in_bytes_method ?
3720 implementation->size_in_bytes_method(h) :
3721 implementation->static_size);
3723 lcrecord_stats[type_index].instances_freed++;
3724 lcrecord_stats[type_index].bytes_freed += sz;
3726 lcrecord_stats[type_index].instances_in_use++;
3727 lcrecord_stats[type_index].bytes_in_use += sz;
3733 /* Free all unmarked records */
3734 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3736 sweep_lcrecords_1(struct lcrecord_header *volatile*prev, int *used)
3739 /* int total_size = 0; */
3741 xzero(lcrecord_stats); /* Reset all statistics to 0. */
3743 /* First go through and call all the finalize methods.
3744 Then go through and free the objects. There used to
3745 be only one loop here, with the call to the finalizer
3746 occurring directly before the xfree() below. That
3747 is marginally faster but much less safe -- if the
3748 finalize method for an object needs to reference any
3749 other objects contained within it (and many do),
3750 we could easily be screwed by having already freed that
3753 for (struct lcrecord_header *volatile header = *prev;
3754 header; header = header->next) {
3755 struct lrecord_header *h = &(header->lheader);
3757 GC_CHECK_LHEADER_INVARIANTS(h);
3759 if (!MARKED_RECORD_HEADER_P(h) && !header->free) {
3760 if (LHEADER_IMPLEMENTATION(h)->finalizer)
3761 LHEADER_IMPLEMENTATION(h)->finalizer(h, 0);
3765 for (struct lcrecord_header *volatile header = *prev; header;) {
3766 struct lrecord_header *volatile h = &(header->lheader);
3767 if (MARKED_RECORD_HEADER_P(h)) {
3768 if (!C_READONLY_RECORD_HEADER_P(h))
3769 UNMARK_RECORD_HEADER(h);
3771 /* total_size += n->implementation->size_in_bytes (h); */
3772 /* #### May modify header->next on a C_READONLY lcrecord */
3773 prev = &(header->next);
3775 tick_lcrecord_stats(h, 0);
3777 struct lcrecord_header *next = header->next;
3779 tick_lcrecord_stats(h, 1);
3780 /* used to call finalizer right here. */
3786 /* *total = total_size; */
3791 sweep_bit_vectors_1(Lisp_Object * prev, int *used, int *total, int *storage)
3793 Lisp_Object bit_vector;
3796 int total_storage = 0;
3798 /* BIT_VECTORP fails because the objects are marked, which changes
3799 their implementation */
3800 for (bit_vector = *prev; !EQ(bit_vector, Qzero);) {
3801 Lisp_Bit_Vector *v = XBIT_VECTOR(bit_vector);
3803 if (MARKED_RECORD_P(bit_vector)) {
3804 if (!C_READONLY_RECORD_HEADER_P(&(v->lheader)))
3805 UNMARK_RECORD_HEADER(&(v->lheader));
3809 FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Bit_Vector,
3810 unsigned long, bits,
3811 BIT_VECTOR_LONG_STORAGE
3814 /* #### May modify next on a C_READONLY bitvector */
3815 prev = &(bit_vector_next(v));
3818 Lisp_Object next = bit_vector_next(v);
3825 *total = total_size;
3826 *storage = total_storage;
3830 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3831 to make macros prettier. */
3833 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3834 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type)
3836 #elif defined ERROR_CHECK_GC
3838 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3840 struct typename##_block *SFTB_current; \
3842 int num_free = 0, num_used = 0; \
3844 for (SFTB_current = current_##typename##_block, \
3845 SFTB_limit = current_##typename##_block_index; \
3850 for (SFTB_iii = 0; \
3851 SFTB_iii < SFTB_limit; \
3853 obj_type *SFTB_victim = \
3854 &(SFTB_current->block[SFTB_iii]); \
3856 if (LRECORD_FREE_P (SFTB_victim)) { \
3858 } else if (C_READONLY_RECORD_HEADER_P \
3859 (&SFTB_victim->lheader)) { \
3861 } else if (!MARKED_RECORD_HEADER_P \
3862 (&SFTB_victim->lheader)) { \
3864 FREE_FIXED_TYPE(typename, obj_type, \
3868 UNMARK_##typename(SFTB_victim); \
3871 SFTB_current = SFTB_current->prev; \
3872 SFTB_limit = countof(current_##typename##_block \
3876 gc_count_num_##typename##_in_use = num_used; \
3877 gc_count_num_##typename##_freelist = num_free; \
3880 #else /* !ERROR_CHECK_GC, !BDWGC*/
3882 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3884 struct typename##_block *SFTB_current; \
3885 struct typename##_block **SFTB_prev; \
3887 int num_free = 0, num_used = 0; \
3889 typename##_free_list = 0; \
3891 for (SFTB_prev = ¤t_##typename##_block, \
3892 SFTB_current = current_##typename##_block, \
3893 SFTB_limit = current_##typename##_block_index; \
3897 int SFTB_empty = 1; \
3898 Lisp_Free *SFTB_old_free_list = \
3899 typename##_free_list; \
3901 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; \
3903 obj_type *SFTB_victim = \
3904 &(SFTB_current->block[SFTB_iii]); \
3906 if (LRECORD_FREE_P (SFTB_victim)) { \
3908 PUT_FIXED_TYPE_ON_FREE_LIST \
3909 (typename, obj_type, \
3911 } else if (C_READONLY_RECORD_HEADER_P \
3912 (&SFTB_victim->lheader)) { \
3915 } else if (! MARKED_RECORD_HEADER_P \
3916 (&SFTB_victim->lheader)) { \
3918 FREE_FIXED_TYPE(typename, obj_type, \
3923 UNMARK_##typename (SFTB_victim); \
3926 if (!SFTB_empty) { \
3927 SFTB_prev = &(SFTB_current->prev); \
3928 SFTB_current = SFTB_current->prev; \
3929 } else if (SFTB_current == current_##typename##_block \
3930 && !SFTB_current->prev) { \
3931 /* No real point in freeing sole \
3932 * allocation block */ \
3935 struct typename##_block *SFTB_victim_block = \
3937 if (SFTB_victim_block == \
3938 current_##typename##_block) { \
3939 current_##typename##_block_index \
3941 (current_##typename##_block \
3944 SFTB_current = SFTB_current->prev; \
3946 *SFTB_prev = SFTB_current; \
3947 xfree(SFTB_victim_block); \
3948 /* Restore free list to what it was \
3949 before victim was swept */ \
3950 typename##_free_list = \
3951 SFTB_old_free_list; \
3952 num_free -= SFTB_limit; \
3955 SFTB_limit = countof (current_##typename##_block \
3959 gc_count_num_##typename##_in_use = num_used; \
3960 gc_count_num_##typename##_freelist = num_free; \
3963 #endif /* !ERROR_CHECK_GC */
3965 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3966 static void sweep_conses(void)
3968 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3969 #define ADDITIONAL_FREE_cons(ptr)
3971 SWEEP_FIXED_TYPE_BLOCK(cons, Lisp_Cons);
3975 /* Explicitly free a cons cell. */
3976 void free_cons(Lisp_Cons * ptr)
3978 #ifdef ERROR_CHECK_GC
3979 /* If the CAR is not an int, then it will be a pointer, which will
3980 always be four-byte aligned. If this cons cell has already been
3981 placed on the free list, however, its car will probably contain
3982 a chain pointer to the next cons on the list, which has cleverly
3983 had all its 0's and 1's inverted. This allows for a quick
3984 check to make sure we're not freeing something already freed. */
3985 if (POINTER_TYPE_P(XTYPE(ptr->car)))
3986 ASSERT_VALID_POINTER(XPNTR(ptr->car));
3987 #endif /* ERROR_CHECK_GC */
3989 #ifndef ALLOC_NO_POOLS
3990 FREE_FIXED_TYPE_WHEN_NOT_IN_GC(cons, Lisp_Cons, ptr);
3991 #endif /* ALLOC_NO_POOLS */
3994 /* explicitly free a list. You **must make sure** that you have
3995 created all the cons cells that make up this list and that there
3996 are no pointers to any of these cons cells anywhere else. If there
3997 are, you will lose. */
3999 void free_list(Lisp_Object list)
4001 Lisp_Object rest, next;
4003 for (rest = list; !NILP(rest); rest = next) {
4005 free_cons(XCONS(rest));
4009 /* explicitly free an alist. You **must make sure** that you have
4010 created all the cons cells that make up this alist and that there
4011 are no pointers to any of these cons cells anywhere else. If there
4012 are, you will lose. */
4014 void free_alist(Lisp_Object alist)
4016 Lisp_Object rest, next;
4018 for (rest = alist; !NILP(rest); rest = next) {
4020 free_cons(XCONS(XCAR(rest)));
4021 free_cons(XCONS(rest));
4025 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4026 static void sweep_compiled_functions(void)
4028 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4029 #define ADDITIONAL_FREE_compiled_function(ptr)
4031 SWEEP_FIXED_TYPE_BLOCK(compiled_function, Lisp_Compiled_Function);
4035 static void sweep_floats(void)
4037 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4038 #define ADDITIONAL_FREE_float(ptr)
4040 SWEEP_FIXED_TYPE_BLOCK(float, Lisp_Float);
4042 #endif /* HAVE_FPFLOAT */
4044 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
4048 #define UNMARK_bigz(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4049 #define ADDITIONAL_FREE_bigz(ptr) bigz_fini(ptr->data)
4051 SWEEP_FIXED_TYPE_BLOCK(bigz, Lisp_Bigz);
4053 #endif /* HAVE_MPZ */
4055 #if defined HAVE_MPQ && defined WITH_GMP
4059 #define UNMARK_bigq(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4060 #define ADDITIONAL_FREE_bigq(ptr) bigq_fini(ptr->data)
4062 SWEEP_FIXED_TYPE_BLOCK(bigq, Lisp_Bigq);
4064 #endif /* HAVE_MPQ */
4066 #if defined HAVE_MPF && defined WITH_GMP
4070 #define UNMARK_bigf(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4071 #define ADDITIONAL_FREE_bigf(ptr) bigf_fini(ptr->data)
4073 SWEEP_FIXED_TYPE_BLOCK(bigf, Lisp_Bigf);
4075 #endif /* HAVE_MPF */
4077 #if defined HAVE_MPFR && defined WITH_MPFR
4081 #define UNMARK_bigfr(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4082 #define ADDITIONAL_FREE_bigfr(ptr) bigfr_fini(ptr->data)
4084 SWEEP_FIXED_TYPE_BLOCK(bigfr, Lisp_Bigfr);
4086 #endif /* HAVE_MPFR */
4088 #if defined HAVE_PSEUG && defined WITH_PSEUG
4092 #define UNMARK_bigg(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4093 #define ADDITIONAL_FREE_bigg(ptr) bigg_fini(ptr->data)
4095 SWEEP_FIXED_TYPE_BLOCK(bigg, Lisp_Bigg);
4097 #endif /* HAVE_PSEUG */
4099 #if defined HAVE_MPC && defined WITH_MPC || \
4100 defined HAVE_PSEUC && defined WITH_PSEUC
4104 #define UNMARK_bigc(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4105 #define ADDITIONAL_FREE_bigc(ptr) bigc_fini(ptr->data)
4107 SWEEP_FIXED_TYPE_BLOCK(bigc, Lisp_Bigc);
4109 #endif /* HAVE_MPC */
4111 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
4113 sweep_quaterns (void)
4115 #define UNMARK_quatern(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4116 #define ADDITIONAL_FREE_quatern(ptr) quatern_fini(ptr->data)
4118 SWEEP_FIXED_TYPE_BLOCK(quatern, Lisp_Quatern);
4120 #endif /* HAVE_QUATERN */
4123 sweep_dynacats(void)
4125 #define UNMARK_dynacat(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4126 #define ADDITIONAL_FREE_dynacat(ptr) dynacat_fini(ptr);
4128 SWEEP_FIXED_TYPE_BLOCK(dynacat, struct dynacat_s);
4131 static void sweep_symbols(void)
4133 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4134 #define ADDITIONAL_FREE_symbol(ptr)
4136 SWEEP_FIXED_TYPE_BLOCK(symbol, Lisp_Symbol);
4139 static void sweep_extents(void)
4141 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4142 #define ADDITIONAL_FREE_extent(ptr)
4144 SWEEP_FIXED_TYPE_BLOCK(extent, struct extent);
4147 static void sweep_events(void)
4149 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4150 #define ADDITIONAL_FREE_event(ptr)
4152 SWEEP_FIXED_TYPE_BLOCK(event, Lisp_Event);
4155 static void sweep_markers(void)
4157 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4158 #define ADDITIONAL_FREE_marker(ptr) \
4159 do { Lisp_Object tem; \
4160 XSETMARKER (tem, ptr); \
4161 unchain_marker (tem); \
4164 SWEEP_FIXED_TYPE_BLOCK(marker, Lisp_Marker);
4168 /* Explicitly free a marker. */
4169 void free_marker(Lisp_Marker * ptr)
4171 /* Perhaps this will catch freeing an already-freed marker. */
4172 gc_checking_assert(ptr->lheader.type == lrecord_type_marker);
4174 #ifndef ALLOC_NO_POOLS
4175 FREE_FIXED_TYPE_WHEN_NOT_IN_GC(marker, Lisp_Marker, ptr);
4176 #endif /* ALLOC_NO_POOLS */
4179 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
4181 static void verify_string_chars_integrity(void)
4183 struct string_chars_block *sb;
4185 /* Scan each existing string block sequentially, string by string. */
4186 for (sb = first_string_chars_block; sb; sb = sb->next) {
4188 /* POS is the index of the next string in the block. */
4189 while (pos < sb->pos) {
4190 struct string_chars *s_chars =
4191 (struct string_chars *)&(sb->string_chars[pos]);
4192 Lisp_String *string;
4196 /* If the string_chars struct is marked as free (i.e. the
4197 STRING pointer is NULL) then this is an unused chunk of
4198 string storage. (See below.) */
4200 if (STRING_CHARS_FREE_P(s_chars)) {
4202 ((struct unused_string_chars *)s_chars)->
4208 string = s_chars->string;
4209 /* Must be 32-bit aligned. */
4210 assert((((int)string) & 3) == 0);
4212 size = string_length(string);
4213 fullsize = STRING_FULLSIZE(size);
4215 assert(!BIG_STRING_FULLSIZE_P(fullsize));
4216 assert(string_data(string) == s_chars->chars);
4219 assert(pos == sb->pos);
4223 #endif /* MULE && ERROR_CHECK_GC */
4225 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4226 /* Compactify string chars, relocating the reference to each --
4227 free any empty string_chars_block we see. */
4228 static void compact_string_chars(void)
4230 struct string_chars_block *to_sb = first_string_chars_block;
4232 struct string_chars_block *from_sb;
4234 /* Scan each existing string block sequentially, string by string. */
4235 for (from_sb = first_string_chars_block; from_sb;
4236 from_sb = from_sb->next) {
4238 /* FROM_POS is the index of the next string in the block. */
4239 while (from_pos < from_sb->pos) {
4240 struct string_chars *from_s_chars =
4241 (struct string_chars *)&(from_sb->
4242 string_chars[from_pos]);
4243 struct string_chars *to_s_chars;
4244 Lisp_String *string;
4248 /* If the string_chars struct is marked as free (i.e. the
4249 STRING pointer is NULL) then this is an unused chunk of
4250 string storage. This happens under Mule when a string's
4251 size changes in such a way that its fullsize changes.
4252 (Strings can change size because a different-length
4253 character can be substituted for another character.)
4254 In this case, after the bogus string pointer is the
4255 "fullsize" of this entry, i.e. how many bytes to skip. */
4257 if (STRING_CHARS_FREE_P(from_s_chars)) {
4259 ((struct unused_string_chars *)
4260 from_s_chars)->fullsize;
4261 from_pos += fullsize;
4265 string = from_s_chars->string;
4266 assert(!(LRECORD_FREE_P(string)));
4268 size = string_length(string);
4269 fullsize = STRING_FULLSIZE(size);
4271 gc_checking_assert(!BIG_STRING_FULLSIZE_P(fullsize));
4273 /* Just skip it if it isn't marked. */
4274 if (!MARKED_RECORD_HEADER_P(&(string->lheader))) {
4275 from_pos += fullsize;
4279 /* If it won't fit in what's left of TO_SB, close TO_SB
4280 out and go on to the next string_chars_block. We
4281 know that TO_SB cannot advance past FROM_SB here
4282 since FROM_SB is large enough to currently contain
4284 if ((to_pos + fullsize) >
4285 countof(to_sb->string_chars)) {
4286 to_sb->pos = to_pos;
4287 to_sb = to_sb->next;
4291 /* Compute new address of this string
4292 and update TO_POS for the space being used. */
4294 (struct string_chars *)&(to_sb->
4295 string_chars[to_pos]);
4297 /* Copy the string_chars to the new place. */
4298 if (from_s_chars != to_s_chars)
4299 memmove(to_s_chars, from_s_chars, fullsize);
4301 /* Relocate FROM_S_CHARS's reference */
4302 set_string_data(string, &(to_s_chars->chars[0]));
4304 from_pos += fullsize;
4309 /* Set current to the last string chars block still used and
4310 free any that follow. */
4311 for (volatile struct string_chars_block *victim = to_sb->next;
4313 volatile struct string_chars_block *tofree = victim;
4314 victim = victim->next;
4318 current_string_chars_block = to_sb;
4319 current_string_chars_block->pos = to_pos;
4320 current_string_chars_block->next = 0;
4323 static int debug_string_purity;
4325 static void debug_string_purity_print(Lisp_String * p)
4328 Charcount s = string_char_length(p);
4330 for (i = 0; i < s; i++) {
4331 Emchar ch = string_char(p, i);
4332 if (ch < 32 || ch >= 126)
4333 stderr_out("\\%03o", ch);
4334 else if (ch == '\\' || ch == '\"')
4335 stderr_out("\\%c", ch);
4337 stderr_out("%c", ch);
4343 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4344 static void sweep_strings(void)
4346 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
4347 int debug = debug_string_purity;
4349 #define UNMARK_string(ptr) \
4351 Lisp_String *p = (ptr); \
4352 size_t size = string_length (p); \
4353 UNMARK_RECORD_HEADER (&(p->lheader)); \
4354 num_bytes += size; \
4355 if (!BIG_STRING_SIZE_P (size)) { \
4356 num_small_bytes += size; \
4360 debug_string_purity_print (p); \
4362 #define ADDITIONAL_FREE_string(ptr) \
4364 size_t size = string_length (ptr); \
4365 if (BIG_STRING_SIZE_P(size)) { \
4370 SWEEP_FIXED_TYPE_BLOCK(string, Lisp_String);
4372 gc_count_num_short_string_in_use = num_small_used;
4373 gc_count_string_total_size = num_bytes;
4374 gc_count_short_string_total_size = num_small_bytes;
4378 /* I hate duplicating all this crap! */
4379 int marked_p(Lisp_Object obj)
4381 /* Checks we used to perform. */
4382 /* if (EQ (obj, Qnull_pointer)) return 1; */
4383 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
4384 /* if (PURIFIED (XPNTR (obj))) return 1; */
4386 if (XTYPE(obj) == Lisp_Type_Record) {
4387 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
4389 GC_CHECK_LHEADER_INVARIANTS(lheader);
4391 return MARKED_RECORD_HEADER_P(lheader);
4396 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4397 static void gc_sweep(void)
4399 /* Free all unmarked records. Do this at the very beginning,
4400 before anything else, so that the finalize methods can safely
4401 examine items in the objects. sweep_lcrecords_1() makes
4402 sure to call all the finalize methods *before* freeing anything,
4403 to complete the safety. */
4406 sweep_lcrecords_1(&all_lcrecords, &ignored);
4409 compact_string_chars();
4411 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
4412 macros) must be *extremely* careful to make sure they're not
4413 referencing freed objects. The only two existing finalize
4414 methods (for strings and markers) pass muster -- the string
4415 finalizer doesn't look at anything but its own specially-
4416 created block, and the marker finalizer only looks at live
4417 buffers (which will never be freed) and at the markers before
4418 and after it in the chain (which, by induction, will never be
4419 freed because if so, they would have already removed themselves
4422 /* Put all unmarked strings on free list, free'ing the string chars
4423 of large unmarked strings */
4426 /* Put all unmarked conses on free list */
4429 /* Free all unmarked bit vectors */
4430 sweep_bit_vectors_1(&all_bit_vectors,
4431 &gc_count_num_bit_vector_used,
4432 &gc_count_bit_vector_total_size,
4433 &gc_count_bit_vector_storage);
4435 /* Free all unmarked compiled-function objects */
4436 sweep_compiled_functions();
4439 /* Put all unmarked floats on free list */
4441 #endif /* HAVE_FPFLOAT */
4443 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
4444 /* Put all unmarked bignums on free list */
4446 #endif /* HAVE_MPZ */
4448 #if defined HAVE_MPQ && defined WITH_GMP
4449 /* Put all unmarked ratios on free list */
4451 #endif /* HAVE_MPQ */
4453 #if defined HAVE_MPF && defined WITH_GMP
4454 /* Put all unmarked bigfloats on free list */
4456 #endif /* HAVE_MPF */
4458 #if defined HAVE_MPFR && defined WITH_MPFR
4459 /* Put all unmarked bigfloats on free list */
4461 #endif /* HAVE_MPFR */
4463 #if defined HAVE_PSEUG && defined WITH_PSEUG
4464 /* Put all unmarked gaussian numbers on free list */
4466 #endif /* HAVE_PSEUG */
4468 #if defined HAVE_MPC && defined WITH_MPC || \
4469 defined HAVE_PSEUC && defined WITH_PSEUC
4470 /* Put all unmarked complex numbers on free list */
4472 #endif /* HAVE_MPC */
4474 #if defined HAVE_QUATERN && defined WITH_QUATERN
4475 /* Put all unmarked quaternions on free list */
4477 #endif /* HAVE_QUATERN */
4479 /* Put all unmarked dynacats on free list */
4482 /* Put all unmarked symbols on free list */
4485 /* Put all unmarked extents on free list */
4488 /* Put all unmarked markers on free list.
4489 Dechain each one first from the buffer into which it points. */
4495 pdump_objects_unmark();
4500 /* Clearing for disksave. */
4502 void disksave_object_finalization(void)
4504 /* It's important that certain information from the environment not get
4505 dumped with the executable (pathnames, environment variables, etc.).
4506 To make it easier to tell when this has happened with strings(1) we
4507 clear some known-to-be-garbage blocks of memory, so that leftover
4508 results of old evaluation don't look like potential problems.
4509 But first we set some notable variables to nil and do one more GC,
4510 to turn those strings into garbage.
4513 /* Yeah, this list is pretty ad-hoc... */
4514 Vprocess_environment = Qnil;
4515 /* Vexec_directory = Qnil; */
4516 Vdata_directory = Qnil;
4517 Vdoc_directory = Qnil;
4518 Vconfigure_info_directory = Qnil;
4521 /* Vdump_load_path = Qnil; */
4522 /* Release hash tables for locate_file */
4523 Flocate_file_clear_hashing(Qt);
4524 uncache_home_directory();
4526 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
4527 defined(LOADHIST_BUILTIN))
4528 Vload_history = Qnil;
4530 Vshell_file_name = Qnil;
4532 garbage_collect_1();
4534 /* Run the disksave finalization methods of all live objects. */
4535 disksave_object_finalization_1();
4537 /* Zero out the uninitialized (really, unused) part of the containers
4538 for the live strings. */
4539 /* dont know what its counterpart in bdwgc mode is, so leave it out */
4540 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4542 struct string_chars_block *scb;
4543 for (scb = first_string_chars_block; scb; scb = scb->next) {
4544 int count = sizeof(scb->string_chars) - scb->pos;
4546 assert(count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
4548 /* from the block's fill ptr to the end */
4549 memset((scb->string_chars + scb->pos), 0,
4556 /* There, that ought to be enough... */
4560 Lisp_Object restore_gc_inhibit(Lisp_Object val)
4562 gc_currently_forbidden = XINT(val);
4566 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
4567 static int gc_hooks_inhibited;
4569 struct post_gc_action {
4570 void (*fun) (void *);
4574 typedef struct post_gc_action post_gc_action;
4577 Dynarr_declare(post_gc_action);
4578 } post_gc_action_dynarr;
4580 static post_gc_action_dynarr *post_gc_actions;
4582 /* Register an action to be called at the end of GC.
4583 gc_in_progress is 0 when this is called.
4584 This is used when it is discovered that an action needs to be taken,
4585 but it's during GC, so it's not safe. (e.g. in a finalize method.)
4587 As a general rule, do not use Lisp objects here.
4588 And NEVER signal an error.
4591 void register_post_gc_action(void (*fun) (void *), void *arg)
4593 post_gc_action action;
4595 if (!post_gc_actions)
4596 post_gc_actions = Dynarr_new(post_gc_action);
4601 Dynarr_add(post_gc_actions, action);
4604 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4605 static void run_post_gc_actions(void)
4609 if (post_gc_actions) {
4610 for (i = 0; i < Dynarr_length(post_gc_actions); i++) {
4611 post_gc_action action = Dynarr_at(post_gc_actions, i);
4612 (action.fun) (action.arg);
4615 Dynarr_reset(post_gc_actions);
4621 mark_gcprolist(struct gcpro *gcpl)
4625 for (tail = gcpl; tail; tail = tail->next) {
4626 for (i = 0; i < tail->nvars; i++) {
4627 mark_object(tail->var[i]);
4633 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4642 void garbage_collect_1(void)
4644 SXE_DEBUG_GC("GC\n");
4645 #if defined GC_DEBUG_FLAG
4647 #endif /* GC_DEBUG_FLAG */
4649 GC_collect_a_little();
4653 GC_try_to_collect(stop_gc_p);
4659 void garbage_collect_1(void)
4661 #if MAX_SAVE_STACK > 0
4662 char stack_top_variable;
4663 extern char *stack_bottom;
4668 Lisp_Object pre_gc_cursor;
4669 struct gcpro gcpro1;
4672 || gc_currently_forbidden || in_display || preparing_for_armageddon)
4675 /* We used to call selected_frame() here.
4677 The following functions cannot be called inside GC
4678 so we move to after the above tests. */
4681 Lisp_Object device = Fselected_device(Qnil);
4682 /* Could happen during startup, eg. if always_gc */
4686 frame = DEVICE_SELECTED_FRAME(XDEVICE(device));
4688 signal_simple_error("No frames exist on device",
4694 pre_gc_cursor = Qnil;
4697 GCPRO1(pre_gc_cursor);
4699 /* Very important to prevent GC during any of the following
4700 stuff that might run Lisp code; otherwise, we'll likely
4701 have infinite GC recursion. */
4702 speccount = specpdl_depth();
4703 record_unwind_protect(restore_gc_inhibit,
4704 make_int(gc_currently_forbidden));
4705 gc_currently_forbidden = 1;
4707 if (!gc_hooks_inhibited)
4708 run_hook_trapping_errors("Error in pre-gc-hook", Qpre_gc_hook);
4710 /* Now show the GC cursor/message. */
4711 if (!noninteractive) {
4712 if (FRAME_WIN_P(f)) {
4713 Lisp_Object frame = make_frame(f);
4714 Lisp_Object cursor =
4715 glyph_image_instance(Vgc_pointer_glyph,
4716 FRAME_SELECTED_WINDOW(f),
4718 pre_gc_cursor = f->pointer;
4719 if (POINTER_IMAGE_INSTANCEP(cursor)
4720 /* don't change if we don't know how to change
4722 && POINTER_IMAGE_INSTANCEP(pre_gc_cursor)) {
4724 Fset_frame_pointer(frame, cursor);
4728 /* Don't print messages to the stream device. */
4729 if (STRINGP(Vgc_message) &&
4731 !FRAME_STREAM_P(f)) {
4732 char *msg = GETTEXT((char *) XSTRING_DATA(Vgc_message));
4733 Lisp_Object args[2], whole_msg;
4735 args[0] = build_string(
4736 msg ? msg : GETTEXT((char*)gc_default_message));
4737 args[1] = build_string("...");
4738 whole_msg = Fconcat(2, args);
4739 echo_area_message(f, (Bufbyte *) 0, whole_msg, 0, -1,
4740 Qgarbage_collecting);
4744 /***** Now we actually start the garbage collection. */
4748 inhibit_non_essential_printing_operations = 1;
4750 gc_generation_number[0]++;
4752 #if MAX_SAVE_STACK > 0
4754 /* Save a copy of the contents of the stack, for debugging. */
4756 /* Static buffer in which we save a copy of the C stack at each
4758 static char *stack_copy;
4759 static size_t stack_copy_size;
4761 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
4762 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
4763 if (stack_size < MAX_SAVE_STACK) {
4764 if (stack_copy_size < stack_size) {
4766 (char *)xrealloc(stack_copy, stack_size);
4767 stack_copy_size = stack_size;
4772 0 ? stack_bottom : &stack_top_variable,
4776 #endif /* MAX_SAVE_STACK > 0 */
4778 /* Do some totally ad-hoc resource clearing. */
4779 /* #### generalize this? */
4780 clear_event_resource();
4781 cleanup_specifiers();
4783 /* Mark all the special slots that serve as the roots of
4787 Lisp_Object **p = Dynarr_begin(staticpros);
4789 for (count = Dynarr_length(staticpros); count; count--) {
4794 { /* staticpro_nodump() */
4795 Lisp_Object **p = Dynarr_begin(staticpros_nodump);
4797 for (count = Dynarr_length(staticpros_nodump); count; count--) {
4802 #if defined(EF_USE_ASYNEQ)
4803 WITH_DLLIST_TRAVERSE(
4805 eq_worker_t eqw = dllist_item;
4806 struct gcpro *gcpl = eqw->gcprolist;
4807 mark_gcprolist(gcpl));
4810 mark_gcprolist(gcprolist);
4813 struct specbinding *bind;
4814 for (bind = specpdl; bind != specpdl_ptr; bind++) {
4815 mark_object(bind->symbol);
4816 mark_object(bind->old_value);
4821 struct catchtag *catch;
4822 for (catch = catchlist; catch; catch = catch->next) {
4823 mark_object(catch->tag);
4824 mark_object(catch->val);
4829 struct backtrace *backlist;
4830 for (backlist = backtrace_list; backlist;
4831 backlist = backlist->next) {
4832 int nargs = backlist->nargs;
4835 mark_object(*backlist->function);
4837 0 /* nargs == UNEVALLED || nargs == MANY */ )
4838 mark_object(backlist->args[0]);
4840 for (i = 0; i < nargs; i++)
4841 mark_object(backlist->args[i]);
4846 mark_profiling_info();
4848 /* OK, now do the after-mark stuff. This is for things that are only
4849 marked when something else is marked (e.g. weak hash tables). There
4850 may be complex dependencies between such objects -- e.g. a weak hash
4851 table might be unmarked, but after processing a later weak hash
4852 table, the former one might get marked. So we have to iterate until
4853 nothing more gets marked. */
4854 while (finish_marking_weak_hash_tables() > 0 ||
4855 finish_marking_weak_lists() > 0) ;
4857 /* And prune (this needs to be called after everything else has been
4858 marked and before we do any sweeping). */
4859 /* #### this is somewhat ad-hoc and should probably be an object
4861 prune_weak_hash_tables();
4864 prune_syntax_tables();
4868 consing_since_gc = 0;
4869 #ifndef DEBUG_SXEMACS
4870 /* Allow you to set it really fucking low if you really want ... */
4871 if (gc_cons_threshold < 10000)
4872 gc_cons_threshold = 10000;
4876 inhibit_non_essential_printing_operations = 0;
4879 run_post_gc_actions();
4881 /******* End of garbage collection ********/
4883 run_hook_trapping_errors("Error in post-gc-hook", Qpost_gc_hook);
4885 /* Now remove the GC cursor/message */
4886 if (!noninteractive) {
4888 Fset_frame_pointer(make_frame(f), pre_gc_cursor);
4889 else if (STRINGP(Vgc_message) && !FRAME_STREAM_P(f)) {
4890 char *msg = GETTEXT((char *)XSTRING_DATA(Vgc_message));
4892 /* Show "...done" only if the echo area would otherwise
4894 if (NILP(clear_echo_area(selected_frame(),
4895 Qgarbage_collecting, 0))) {
4896 Lisp_Object args[2], whole_msg;
4897 args[0] = build_string(
4899 : GETTEXT((char*)gc_default_message));
4900 args[1] = build_string("... done");
4901 whole_msg = Fconcat(2, args);
4902 echo_area_message(selected_frame(),
4903 (Bufbyte *) 0, whole_msg, 0,
4904 -1, Qgarbage_collecting);
4909 /* now stop inhibiting GC */
4910 unbind_to(speccount, Qnil);
4912 if (!breathing_space) {
4913 breathing_space = malloc(0xFFFF - MALLOC_OVERHEAD);
4922 /* Debugging aids. */
4923 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4924 #define HACK_O_MATIC(args...)
4925 #define gc_plist_hack(name, val, tail) \
4926 cons3(intern(name), Qzero, tail)
4930 static Lisp_Object gc_plist_hack(const char *name, int value, Lisp_Object tail)
4932 /* C doesn't have local functions (or closures, or GC, or readable
4933 syntax, or portable numeric datatypes, or bit-vectors, or characters,
4934 or arrays, or exceptions, or ...) */
4935 return cons3(intern(name), make_int(value), tail);
4938 #define HACK_O_MATIC(type, name, pl) \
4941 struct type##_block *x = current_##type##_block; \
4943 s += sizeof (*x) + MALLOC_OVERHEAD; \
4946 (pl) = gc_plist_hack ((name), s, (pl)); \
4950 DEFUN("garbage-collect", Fgarbage_collect, 0, 0, "", /*
4951 Reclaim storage for Lisp objects no longer needed.
4952 Return info on amount of space in use:
4953 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4954 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4956 where `PLIST' is a list of alternating keyword/value pairs providing
4957 more detailed information.
4958 Garbage collection happens automatically if you cons more than
4959 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4963 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4967 Lisp_Object pl = Qnil;
4969 int gc_count_vector_total_size = 0;
4971 garbage_collect_1();
4973 for (i = 0; i < lrecord_type_count; i++) {
4974 if (lcrecord_stats[i].bytes_in_use != 0
4975 || lcrecord_stats[i].bytes_freed != 0
4976 || lcrecord_stats[i].instances_on_free_list != 0) {
4979 lrecord_implementations_table[i]->name;
4980 int len = strlen(name);
4983 /* save this for the FSFmacs-compatible part of the
4985 if (i == lrecord_type_vector)
4986 gc_count_vector_total_size =
4987 lcrecord_stats[i].bytes_in_use +
4988 lcrecord_stats[i].bytes_freed;
4990 sz = snprintf(buf, sizeof(buf), "%s-storage", name);
4991 assert(sz >=0 && (size_t)sz < sizeof(buf));
4992 pl = gc_plist_hack(buf, lcrecord_stats[i].bytes_in_use,
4994 /* Okay, simple pluralization check for
4995 `symbol-value-varalias' */
4996 if (name[len - 1] == 's')
4997 sz = snprintf(buf, sizeof(buf), "%ses-freed", name);
4999 sz = snprintf(buf, sizeof(buf), "%ss-freed", name);
5000 assert(sz >=0 && (size_t)sz < sizeof(buf));
5001 if (lcrecord_stats[i].instances_freed != 0)
5002 pl = gc_plist_hack(buf,
5004 instances_freed, pl);
5005 if (name[len - 1] == 's')
5006 sz = snprintf(buf, sizeof(buf), "%ses-on-free-list", name);
5008 sz = snprintf(buf, sizeof(buf), "%ss-on-free-list", name);
5009 assert(sz >=0 && (size_t)sz < sizeof(buf));
5010 if (lcrecord_stats[i].instances_on_free_list != 0)
5011 pl = gc_plist_hack(buf,
5013 instances_on_free_list, pl);
5014 if (name[len - 1] == 's')
5015 sz = snprintf(buf, sizeof(buf), "%ses-used", name);
5017 sz = snprintf(buf, sizeof(buf), "%ss-used", name);
5018 assert(sz >=0 && (size_t)sz < sizeof(buf));
5019 pl = gc_plist_hack(buf,
5020 lcrecord_stats[i].instances_in_use,
5025 HACK_O_MATIC(extent, "extent-storage", pl);
5026 pl = gc_plist_hack("extents-free", gc_count_num_extent_freelist, pl);
5027 pl = gc_plist_hack("extents-used", gc_count_num_extent_in_use, pl);
5028 HACK_O_MATIC(event, "event-storage", pl);
5029 pl = gc_plist_hack("events-free", gc_count_num_event_freelist, pl);
5030 pl = gc_plist_hack("events-used", gc_count_num_event_in_use, pl);
5031 HACK_O_MATIC(marker, "marker-storage", pl);
5032 pl = gc_plist_hack("markers-free", gc_count_num_marker_freelist, pl);
5033 pl = gc_plist_hack("markers-used", gc_count_num_marker_in_use, pl);
5035 HACK_O_MATIC(float, "float-storage", pl);
5036 pl = gc_plist_hack("floats-free", gc_count_num_float_freelist, pl);
5037 pl = gc_plist_hack("floats-used", gc_count_num_float_in_use, pl);
5038 #endif /* HAVE_FPFLOAT */
5039 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
5040 HACK_O_MATIC(bigz, "bigz-storage", pl);
5041 pl = gc_plist_hack("bigzs-free", gc_count_num_bigz_freelist, pl);
5042 pl = gc_plist_hack("bigzs-used", gc_count_num_bigz_in_use, pl);
5043 #endif /* HAVE_MPZ */
5044 #if defined HAVE_MPQ && defined WITH_GMP
5045 HACK_O_MATIC(bigq, "bigq-storage", pl);
5046 pl = gc_plist_hack("bigqs-free", gc_count_num_bigq_freelist, pl);
5047 pl = gc_plist_hack("bigqs-used", gc_count_num_bigq_in_use, pl);
5048 #endif /* HAVE_MPQ */
5049 #if defined HAVE_MPF && defined WITH_GMP
5050 HACK_O_MATIC(bigf, "bigf-storage", pl);
5051 pl = gc_plist_hack("bigfs-free", gc_count_num_bigf_freelist, pl);
5052 pl = gc_plist_hack("bigfs-used", gc_count_num_bigf_in_use, pl);
5053 #endif /* HAVE_MPF */
5054 #if defined HAVE_MPFR && defined WITH_MPFR
5055 HACK_O_MATIC(bigfr, "bigfr-storage", pl);
5056 pl = gc_plist_hack("bigfrs-free", gc_count_num_bigfr_freelist, pl);
5057 pl = gc_plist_hack("bigfrs-used", gc_count_num_bigfr_in_use, pl);
5058 #endif /* HAVE_MPFR */
5059 #if defined HAVE_PSEUG && defined WITH_PSEUG
5060 HACK_O_MATIC(bigg, "bigg-storage", pl);
5061 pl = gc_plist_hack("biggs-free", gc_count_num_bigg_freelist, pl);
5062 pl = gc_plist_hack("biggs-used", gc_count_num_bigg_in_use, pl);
5063 #endif /* HAVE_PSEUG */
5064 #if defined HAVE_MPC && defined WITH_MPC || \
5065 defined HAVE_PSEUC && defined WITH_PSEUC
5066 HACK_O_MATIC(bigc, "bigc-storage", pl);
5067 pl = gc_plist_hack("bigcs-free", gc_count_num_bigc_freelist, pl);
5068 pl = gc_plist_hack("bigcs-used", gc_count_num_bigc_in_use, pl);
5069 #endif /* HAVE_MPC */
5070 #if defined HAVE_QUATERN && defined WITH_QUATERN
5071 HACK_O_MATIC(quatern, "quatern-storage", pl);
5072 pl = gc_plist_hack("quaterns-free", gc_count_num_quatern_freelist, pl);
5073 pl = gc_plist_hack("quaterns-used", gc_count_num_quatern_in_use, pl);
5074 #endif /* HAVE_QUATERN */
5076 HACK_O_MATIC(dynacat, "dynacat-storage", pl);
5077 pl = gc_plist_hack("dynacats-free", gc_count_num_dynacat_freelist, pl);
5078 pl = gc_plist_hack("dynacats-used", gc_count_num_dynacat_in_use, pl);
5080 HACK_O_MATIC(string, "string-header-storage", pl);
5081 pl = gc_plist_hack("long-strings-total-length",
5082 gc_count_string_total_size
5083 - gc_count_short_string_total_size, pl);
5084 HACK_O_MATIC(string_chars, "short-string-storage", pl);
5085 pl = gc_plist_hack("short-strings-total-length",
5086 gc_count_short_string_total_size, pl);
5087 pl = gc_plist_hack("strings-free", gc_count_num_string_freelist, pl);
5088 pl = gc_plist_hack("long-strings-used",
5089 gc_count_num_string_in_use
5090 - gc_count_num_short_string_in_use, pl);
5091 pl = gc_plist_hack("short-strings-used",
5092 gc_count_num_short_string_in_use, pl);
5094 HACK_O_MATIC(compiled_function, "compiled-function-storage", pl);
5095 pl = gc_plist_hack("compiled-functions-free",
5096 gc_count_num_compiled_function_freelist, pl);
5097 pl = gc_plist_hack("compiled-functions-used",
5098 gc_count_num_compiled_function_in_use, pl);
5100 pl = gc_plist_hack("bit-vector-storage", gc_count_bit_vector_storage,
5102 pl = gc_plist_hack("bit-vectors-total-length",
5103 gc_count_bit_vector_total_size, pl);
5104 pl = gc_plist_hack("bit-vectors-used", gc_count_num_bit_vector_used,
5107 HACK_O_MATIC(symbol, "symbol-storage", pl);
5108 pl = gc_plist_hack("symbols-free", gc_count_num_symbol_freelist, pl);
5109 pl = gc_plist_hack("symbols-used", gc_count_num_symbol_in_use, pl);
5111 HACK_O_MATIC(cons, "cons-storage", pl);
5112 pl = gc_plist_hack("conses-free", gc_count_num_cons_freelist, pl);
5113 pl = gc_plist_hack("conses-used", gc_count_num_cons_in_use, pl);
5115 /* The things we do for backwards-compatibility */
5116 /* fuck, what are we doing about those in the bdwgc era? -hrop */
5118 list6(Fcons(make_int(gc_count_num_cons_in_use),
5119 make_int(gc_count_num_cons_freelist)),
5120 Fcons(make_int(gc_count_num_symbol_in_use),
5121 make_int(gc_count_num_symbol_freelist)),
5122 Fcons(make_int(gc_count_num_marker_in_use),
5123 make_int(gc_count_num_marker_freelist)),
5124 make_int(gc_count_string_total_size),
5125 make_int(gc_count_vector_total_size), pl);
5131 /* grrrr ... lisp/itimer-autosave.el is using this, WTF? */
5132 DEFUN("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
5133 Return the number of bytes consed since the last garbage collection.
5134 \"Consed\" is a misnomer in that this actually counts allocation
5135 of all different kinds of objects, not just conses.
5137 If this value exceeds `gc-cons-threshold', a garbage collection happens.
5141 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
5144 return make_int(consing_since_gc);
5149 int object_dead_p(Lisp_Object obj)
5151 return ((BUFFERP(obj) && !BUFFER_LIVE_P(XBUFFER(obj))) ||
5152 (FRAMEP(obj) && !FRAME_LIVE_P(XFRAME(obj))) ||
5153 (WINDOWP(obj) && !WINDOW_LIVE_P(XWINDOW(obj))) ||
5154 (DEVICEP(obj) && !DEVICE_LIVE_P(XDEVICE(obj))) ||
5155 (CONSOLEP(obj) && !CONSOLE_LIVE_P(XCONSOLE(obj))) ||
5156 (EVENTP(obj) && !EVENT_LIVE_P(XEVENT(obj))) ||
5157 (EXTENTP(obj) && !EXTENT_LIVE_P(XEXTENT(obj))));
5160 #if defined MEMORY_USAGE_STATS && !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5162 /* Attempt to determine the actual amount of space that is used for
5163 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
5165 It seems that the following holds:
5167 1. When using the old allocator (malloc.c):
5169 -- blocks are always allocated in chunks of powers of two. For
5170 each block, there is an overhead of 8 bytes if rcheck is not
5171 defined, 20 bytes if it is defined. In other words, a
5172 one-byte allocation needs 8 bytes of overhead for a total of
5173 9 bytes, and needs to have 16 bytes of memory chunked out for
5176 2. When using the new allocator (gmalloc.c):
5178 -- blocks are always allocated in chunks of powers of two up
5179 to 4096 bytes. Larger blocks are allocated in chunks of
5180 an integral multiple of 4096 bytes. The minimum block
5181 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
5182 is defined. There is no per-block overhead, but there
5183 is an overhead of 3*sizeof (size_t) for each 4096 bytes
5186 3. When using the system malloc, anything goes, but they are
5187 generally slower and more space-efficient than the GNU
5188 allocators. One possibly reasonable assumption to make
5189 for want of better data is that sizeof (void *), or maybe
5190 2 * sizeof (void *), is required as overhead and that
5191 blocks are allocated in the minimum required size except
5192 that some minimum block size is imposed (e.g. 16 bytes). */
5195 malloced_storage_size(void *ptr, size_t claimed_size,
5196 struct overhead_stats * stats)
5198 size_t orig_claimed_size = claimed_size;
5202 if (claimed_size < 2 * sizeof(void *))
5203 claimed_size = 2 * sizeof(void *);
5204 # ifdef SUNOS_LOCALTIME_BUG
5205 if (claimed_size < 16)
5208 if (claimed_size < 4096) {
5211 /* compute the log base two, more or less, then use it to compute
5212 the block size needed. */
5214 /* It's big, it's heavy, it's wood! */
5215 while ((claimed_size /= 2) != 0)
5218 /* It's better than bad, it's good! */
5223 /* We have to come up with some average about the amount of
5225 if ((size_t) (rand() & 4095) < claimed_size)
5226 claimed_size += 3 * sizeof(void *);
5228 claimed_size += 4095;
5229 claimed_size &= ~4095;
5230 claimed_size += (claimed_size / 4096) * 3 * sizeof(size_t);
5233 #elif defined (SYSTEM_MALLOC)
5235 if (claimed_size < 16)
5237 claimed_size += 2 * sizeof(void *);
5239 #else /* old GNU allocator */
5241 # ifdef rcheck /* #### may not be defined here */
5249 /* compute the log base two, more or less, then use it to compute
5250 the block size needed. */
5252 /* It's big, it's heavy, it's wood! */
5253 while ((claimed_size /= 2) != 0)
5256 /* It's better than bad, it's good! */
5263 #endif /* old GNU allocator */
5266 stats->was_requested += orig_claimed_size;
5267 stats->malloc_overhead += claimed_size - orig_claimed_size;
5269 return claimed_size;
5272 size_t fixed_type_block_overhead(size_t size)
5274 size_t per_block = TYPE_ALLOC_SIZE(cons, unsigned char);
5275 size_t overhead = 0;
5276 size_t storage_size = malloced_storage_size(0, per_block, 0);
5277 while (size >= per_block) {
5279 overhead += sizeof(void *) + per_block - storage_size;
5281 if (rand() % per_block < size)
5282 overhead += sizeof(void *) + per_block - storage_size;
5286 #endif /* MEMORY_USAGE_STATS */
5288 #ifdef EF_USE_ASYNEQ
5290 init_main_worker(void)
5292 eq_worker_t res = eq_make_worker();
5293 eq_worker_thread(res) = pthread_self();
5298 #if defined HAVE_MPZ && defined WITH_GMP || \
5299 defined HAVE_MPFR && defined WITH_MPFR
5301 my_malloc(size_t bar)
5303 /* we use atomic here since GMP/MPFR do supervise their objects */
5304 void *foo = xmalloc(bar);
5305 SXE_DEBUG_GC_GMP("alloc :is %p :size %lu\n",
5306 foo, (long unsigned int)bar);
5310 /* We need the next two functions since GNU MP insists on giving us an extra
5313 my_realloc (void *ptr, size_t SXE_UNUSED(old_size), size_t new_size)
5315 void *foo = xrealloc(ptr, new_size);
5316 SXE_DEBUG_GC_GMP("gmp realloc :was %p :is %p\n", ptr, foo);
5321 my_free (void *ptr, size_t size)
5323 SXE_DEBUG_GC_GMP("free :was %p :size %lu\n",
5324 ptr, (long unsigned int)size);
5325 memset(ptr, 0, size);
5329 #endif /* GMP || MPFR */
5331 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && !defined GC_DEBUG_FLAG
5333 my_shy_warn_proc(char *msg, GC_word arg)
5335 /* just don't do anything */
5341 /* Initialization */
5342 void init_bdwgc(void);
5347 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
5348 # if defined GC_DEBUG_FLAG
5349 extern long GC_large_alloc_warn_interval;
5351 GC_time_limit = GC_TIME_UNLIMITED;
5352 GC_use_entire_heap = 0;
5355 GC_all_interior_pointers = 1;
5359 GC_free_space_divisor = 8;
5361 #if !defined GC_DEBUG_FLAG
5362 GC_set_warn_proc(my_shy_warn_proc);
5363 #else /* GC_DEBUG_FLAG */
5364 GC_large_alloc_warn_interval = 1L;
5365 #endif /* GC_DEBUG_FLAG */
5372 __init_gmp_mem_funs(void)
5374 #if defined HAVE_MPZ && defined WITH_GMP || \
5375 defined HAVE_MPFR && defined WITH_MPFR
5376 mp_set_memory_functions(my_malloc, my_realloc, my_free);
5377 #endif /* GMP || MPFR */
5380 void reinit_alloc_once_early(void)
5382 gc_generation_number[0] = 0;
5383 breathing_space = NULL;
5384 XSETINT(all_bit_vectors, 0); /* Qzero may not be set yet. */
5385 XSETINT(Vgc_message, 0);
5386 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5389 ignore_malloc_warnings = 1;
5390 #ifdef DOUG_LEA_MALLOC
5391 mallopt(M_TRIM_THRESHOLD, 128 * 1024); /* trim threshold */
5392 mallopt(M_MMAP_THRESHOLD, 64 * 1024); /* mmap threshold */
5393 #if 1 /* Moved to emacs.c */
5394 mallopt(M_MMAP_MAX, 0); /* max. number of mmap'ed areas */
5397 /* the category subsystem */
5398 morphisms[lrecord_type_cons].seq_impl = &__scons;
5399 morphisms[lrecord_type_vector].seq_impl = &__svec;
5400 morphisms[lrecord_type_string].seq_impl = &__sstr;
5401 morphisms[lrecord_type_bit_vector].seq_impl = &__sbvc;
5403 init_string_alloc();
5404 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5405 init_string_chars_alloc();
5408 init_symbol_alloc();
5409 init_compiled_function_alloc();
5413 __init_gmp_mem_funs();
5414 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP) && \
5415 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5418 #if defined HAVE_MPQ && defined WITH_GMP && \
5419 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5422 #if defined HAVE_MPF && defined WITH_GMP && \
5423 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5426 #if defined HAVE_MPFR && defined WITH_MPFR
5429 #if defined HAVE_PSEUG && defined HAVE_MPZ && defined WITH_PSEUG
5432 #if defined HAVE_MPC && defined WITH_MPC || \
5433 defined HAVE_PSEUC && defined WITH_PSEUC
5436 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
5437 init_quatern_alloc();
5439 init_dynacat_alloc();
5441 init_marker_alloc();
5442 init_extent_alloc();
5445 ignore_malloc_warnings = 0;
5447 /* we only use the 500k value for now */
5448 gc_cons_threshold = 500000;
5449 lrecord_uid_counter = 259;
5451 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5452 if (staticpros_nodump) {
5453 Dynarr_free(staticpros_nodump);
5455 staticpros_nodump = Dynarr_new2(Lisp_Object_ptr_dynarr, Lisp_Object *);
5456 /* merely a small optimization */
5457 Dynarr_resize(staticpros_nodump, 100);
5459 /* tuning the GCor */
5460 consing_since_gc = 0;
5461 debug_string_purity = 0;
5463 #ifdef EF_USE_ASYNEQ
5464 workers = make_noseeum_dllist();
5465 dllist_prepend(workers, init_main_worker());
5470 #if defined EF_USE_ASYNEQ && !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5471 SXE_MUTEX_INIT(&cons_mutex);
5474 gc_currently_forbidden = 0;
5475 gc_hooks_inhibited = 0;
5477 #ifdef ERROR_CHECK_TYPECHECK
5479 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5482 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5485 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5487 #endif /* ERROR_CHECK_TYPECHECK */
5490 void init_alloc_once_early(void)
5492 reinit_alloc_once_early();
5494 for (int i = 0; i < countof(lrecord_implementations_table); i++) {
5495 lrecord_implementations_table[i] = 0;
5498 INIT_LRECORD_IMPLEMENTATION(cons);
5499 INIT_LRECORD_IMPLEMENTATION(vector);
5500 INIT_LRECORD_IMPLEMENTATION(string);
5501 INIT_LRECORD_IMPLEMENTATION(lcrecord_list);
5503 staticpros = Dynarr_new2(Lisp_Object_ptr_dynarr, Lisp_Object *);
5504 Dynarr_resize(staticpros, 1410); /* merely a small optimization */
5505 dump_add_root_struct_ptr(&staticpros, &staticpros_description);
5507 /* GMP/MPFR mem funs */
5508 __init_gmp_mem_funs();
5513 void reinit_alloc(void)
5515 #ifdef EF_USE_ASYNEQ
5516 eq_worker_t main_th;
5517 assert(dllist_size(workers) == 1);
5518 main_th = dllist_car(workers);
5519 eq_worker_gcprolist(main_th) = NULL;
5525 void syms_of_alloc(void)
5527 DEFSYMBOL(Qpre_gc_hook);
5528 DEFSYMBOL(Qpost_gc_hook);
5529 DEFSYMBOL(Qgarbage_collecting);
5534 DEFSUBR(Fbit_vector);
5535 DEFSUBR(Fmake_byte_code);
5536 DEFSUBR(Fmake_list);
5537 DEFSUBR(Fmake_vector);
5538 DEFSUBR(Fmake_bit_vector);
5539 DEFSUBR(Fmake_string);
5541 DEFSUBR(Fmake_symbol);
5542 DEFSUBR(Fmake_marker);
5544 DEFSUBR(Fgarbage_collect);
5545 DEFSUBR(Fconsing_since_gc);
5548 void vars_of_alloc(void)
5550 DEFVAR_INT("gc-cons-threshold", &gc_cons_threshold /*
5551 *Number of bytes of consing between garbage collections.
5552 \"Consing\" is a misnomer in that this actually counts allocation
5553 of all different kinds of objects, not just conses.
5554 Garbage collection can happen automatically once this many bytes have been
5555 allocated since the last garbage collection. All data types count.
5557 Garbage collection happens automatically when `eval' or `funcall' are
5558 called. (Note that `funcall' is called implicitly as part of evaluation.)
5559 By binding this temporarily to a large number, you can effectively
5560 prevent garbage collection during a part of the program.
5562 See also `consing-since-gc'.
5565 #ifdef DEBUG_SXEMACS
5566 DEFVAR_INT("debug-allocation", &debug_allocation /*
5567 If non-zero, print out information to stderr about all objects allocated.
5568 See also `debug-allocation-backtrace-length'.
5570 debug_allocation = 0;
5572 DEFVAR_INT("debug-allocation-backtrace-length", &debug_allocation_backtrace_length /*
5573 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
5575 debug_allocation_backtrace_length = 2;
5578 DEFVAR_BOOL("purify-flag", &purify_flag /*
5579 Non-nil means loading Lisp code in order to dump an executable.
5580 This means that certain objects should be allocated in readonly space.
5583 DEFVAR_LISP("pre-gc-hook", &Vpre_gc_hook /*
5584 Function or functions to be run just before each garbage collection.
5585 Interrupts, garbage collection, and errors are inhibited while this hook
5586 runs, so be extremely careful in what you add here. In particular, avoid
5587 consing, and do not interact with the user.
5589 Vpre_gc_hook = Qnil;
5591 DEFVAR_LISP("post-gc-hook", &Vpost_gc_hook /*
5592 Function or functions to be run just after each garbage collection.
5593 Interrupts, garbage collection, and errors are inhibited while this hook
5594 runs, so be extremely careful in what you add here. In particular, avoid
5595 consing, and do not interact with the user.
5597 Vpost_gc_hook = Qnil;
5599 DEFVAR_LISP("gc-message", &Vgc_message /*
5600 String to print to indicate that a garbage collection is in progress.
5601 This is printed in the echo area. If the selected frame is on a
5602 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
5603 image instance) in the domain of the selected frame, the mouse pointer
5604 will change instead of this message being printed.
5605 If it has non-string value - nothing is printed.
5607 Vgc_message = build_string(gc_default_message);
5609 DEFVAR_LISP("gc-pointer-glyph", &Vgc_pointer_glyph /*
5610 Pointer glyph used to indicate that a garbage collection is in progress.
5611 If the selected window is on a window system and this glyph specifies a
5612 value (i.e. a pointer image instance) in the domain of the selected
5613 window, the pointer will be changed as specified during garbage collection.
5614 Otherwise, a message will be printed in the echo area, as controlled
5619 void complex_vars_of_alloc(void)
5621 Vgc_pointer_glyph = Fmake_glyph_internal(Qpointer);