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>
66 #ifdef DOUG_LEA_MALLOC
74 #define SXE_DEBUG_GC_GMP(args...) SXE_DEBUG_GC("[gmp]: " args)
77 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
80 # if defined HAVE_GC_GC_H
82 # elif defined HAVE_GC_H
85 /* declare the 3 funs we need */
86 extern void *GC_malloc(size_t);
87 extern void *GC_malloc_atomic(size_t);
88 extern void *GC_malloc_uncollectable(size_t);
89 extern void *GC_malloc_stubborn(size_t);
90 extern void *GC_realloc(void*, size_t);
91 extern char *GC_strdup(const char*);
92 extern void GC_free(void*);
94 # error "I'm very concerned about your BDWGC support"
98 /* category subsystem */
104 EXFUN(Fgarbage_collect, 0);
107 /* this is _way_ too slow to be part of the standard debug options */
108 #if defined(DEBUG_SXEMACS) && defined(MULE)
109 #define VERIFY_STRING_CHARS_INTEGRITY
113 /* Define this to use malloc/free with no freelist for all datatypes,
114 the hope being that some debugging tools may help detect
115 freed memory references */
116 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
118 #define ALLOC_NO_POOLS
122 static Fixnum debug_allocation;
123 static Fixnum debug_allocation_backtrace_length;
126 #if defined EF_USE_ASYNEQ && !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
127 #include "semaphore.h"
128 sxe_mutex_t cons_mutex;
129 #endif /* EF_USE_ASYNEQ && !BDWGC */
131 #include "events/event-queue.h"
132 #include "events/workers.h"
133 dllist_t workers = NULL;
136 /* Number of bytes of consing done since the last gc */
137 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
138 #define INCREMENT_CONS_COUNTER_1(size)
142 EMACS_INT consing_since_gc;
143 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
148 debug_allocation_backtrace(void)
150 if (debug_allocation_backtrace_length > 0) {
151 debug_short_backtrace (debug_allocation_backtrace_length);
156 #define INCREMENT_CONS_COUNTER(foosize, type) \
158 if (debug_allocation) { \
159 stderr_out("allocating %s (size %ld)\n", \
160 type, (long)foosize); \
161 debug_allocation_backtrace (); \
163 INCREMENT_CONS_COUNTER_1(foosize); \
165 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
167 if (debug_allocation > 1) { \
168 stderr_out("allocating noseeum %s (size %ld)\n", \
169 type, (long)foosize); \
170 debug_allocation_backtrace (); \
172 INCREMENT_CONS_COUNTER_1(foosize); \
175 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
176 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
177 INCREMENT_CONS_COUNTER_1 (size)
181 DECREMENT_CONS_COUNTER(size_t size)
182 __attribute__((always_inline));
185 DECREMENT_CONS_COUNTER(size_t size)
187 consing_since_gc -= (size);
188 if (consing_since_gc < 0) {
189 consing_since_gc = 0;
193 /* Number of bytes of consing since gc before another gc should be done. */
194 EMACS_INT gc_cons_threshold;
196 /* Nonzero during gc */
199 /* Number of times GC has happened at this level or below.
200 * Level 0 is most volatile, contrary to usual convention.
201 * (Of course, there's only one level at present) */
202 EMACS_INT gc_generation_number[1];
204 /* This is just for use by the printer, to allow things to print uniquely */
205 static int lrecord_uid_counter;
207 /* Nonzero when calling certain hooks or doing other things where
209 int gc_currently_forbidden;
212 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
213 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
215 /* "Garbage collecting" */
216 Lisp_Object Vgc_message;
217 Lisp_Object Vgc_pointer_glyph;
218 static char gc_default_message[] = "Garbage collecting";
219 Lisp_Object Qgarbage_collecting;
221 /* Non-zero means we're in the process of doing the dump */
224 #ifdef ERROR_CHECK_TYPECHECK
226 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
230 int c_readonly(Lisp_Object obj)
232 return POINTER_TYPE_P(XTYPE(obj)) && C_READONLY(obj);
235 int lisp_readonly(Lisp_Object obj)
237 return POINTER_TYPE_P(XTYPE(obj)) && LISP_READONLY(obj);
240 /* Maximum amount of C stack to save when a GC happens. */
242 #ifndef MAX_SAVE_STACK
243 #define MAX_SAVE_STACK 0 /* 16000 */
246 /* Non-zero means ignore malloc warnings. Set during initialization. */
247 int ignore_malloc_warnings;
249 static void *breathing_space = NULL;
251 void release_breathing_space(void)
253 if (breathing_space) {
254 void *tmp = breathing_space;
255 breathing_space = NULL;
260 /* malloc calls this if it finds we are near exhausting storage */
261 void malloc_warning(const char *str)
263 if (ignore_malloc_warnings)
269 "Killing some buffers may delay running out of memory.\n"
270 "However, certainly by the time you receive the 95%% warning,\n"
271 "you should clean up, kill this Emacs, and start a new one.", str);
274 /* Called if malloc returns zero */
275 DOESNT_RETURN memory_full(void)
277 /* Force a GC next time eval is called.
278 It's better to loop garbage-collecting (we might reclaim enough
279 to win) than to loop beeping and barfing "Memory exhausted"
281 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
282 /* that's all we can do */
285 consing_since_gc = gc_cons_threshold + 1;
286 release_breathing_space();
289 /* Flush some histories which might conceivably contain garbalogical
291 if (!NILP(Fboundp(Qvalues))) {
294 Vcommand_history = Qnil;
296 error("Memory exhausted");
299 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
300 /* like malloc and realloc but check for no memory left, and block input. */
303 void *xmalloc(size_t size)
305 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
306 /* yes i know this is contradicting because of the outer conditional
307 * but this here and the definition in lisp.h are meant to be
309 void *val = zmalloc(size);
310 #else /* !HAVE_BDWGC */
311 void *val = ymalloc(size);
312 #endif /* HAVE_BDWGC */
314 if (!val && (size != 0))
319 #undef xmalloc_atomic
320 void *xmalloc_atomic(size_t size)
322 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
323 void *val = zmalloc_atomic(size);
324 #else /* !HAVE_BDWGC */
325 void *val = ymalloc_atomic(size);
326 #endif /* HAVE_BDWGC */
328 if (!val && (size != 0))
334 static void *xcalloc(size_t nelem, size_t elsize)
336 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
337 void *val = zcalloc(nelem, elsize);
339 void *val = ycalloc(nelem, elsize);
342 if (!val && (nelem != 0))
347 void *xmalloc_and_zero(size_t size)
349 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
350 return zmalloc_and_zero(size);
352 return xcalloc(size, 1);
357 void *xrealloc(void *block, size_t size)
359 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
360 void *val = zrealloc(block, size);
361 #else /* !HAVE_BDWGC */
362 /* We must call malloc explicitly when BLOCK is 0, since some
363 reallocs don't do this. */
364 void *val = block ? yrealloc(block, size) : ymalloc(size);
365 #endif /* HAVE_BDWGC */
367 if (!val && (size != 0))
373 #ifdef ERROR_CHECK_GC
376 typedef unsigned int four_byte_t;
377 #elif SIZEOF_LONG == 4
378 typedef unsigned long four_byte_t;
379 #elif SIZEOF_SHORT == 4
380 typedef unsigned short four_byte_t;
382 What kind of strange - ass system are we running on ?
384 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
385 static void deadbeef_memory(void *ptr, size_t size)
387 four_byte_t *ptr4 = (four_byte_t *) ptr;
388 size_t beefs = size >> 2;
390 /* In practice, size will always be a multiple of four. */
392 (*ptr4++) = 0xDEADBEEF;
396 #else /* !ERROR_CHECK_GC */
398 #define deadbeef_memory(ptr, size)
400 #endif /* !ERROR_CHECK_GC */
403 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
404 char *xstrdup(const char *str)
406 #ifdef ERROR_CHECK_MALLOC
407 #if SIZEOF_VOID_P == 4
408 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
409 error until much later on for many system mallocs, such as
410 the one that comes with Solaris 2.3. FMH!! */
411 assert(str != (void *)0xDEADBEEF);
412 #elif SIZEOF_VOID_P == 8
413 assert(str != (void*)0xCAFEBABEDEADBEEF);
415 #endif /* ERROR_CHECK_MALLOC */
417 int len = strlen(str)+1; /* for stupid terminating 0 */
419 void *val = xmalloc(len);
422 return (char*)memcpy(val, str, len);
428 #if !defined HAVE_STRDUP
429 /* will be a problem I think */
430 char *strdup(const char *s)
434 #endif /* !HAVE_STRDUP */
438 allocate_lisp_storage(size_t size)
440 return xmalloc(size);
443 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
445 lcrec_register_finaliser(struct lcrecord_header *b)
447 GC_finalization_proc *foo = NULL;
449 auto void lcrec_finaliser();
451 auto void lcrec_finaliser(void *obj, void *SXE_UNUSED(data))
453 const struct lrecord_implementation *lrimp =
454 XRECORD_LHEADER_IMPLEMENTATION(obj);
455 if (LIKELY(lrimp->finalizer != NULL)) {
456 SXE_DEBUG_GC("running the finaliser on %p :type %d\n",
458 lrimp->finalizer(obj, 0);
461 memset(obj, 0, sizeof(struct lcrecord_header));
465 SXE_DEBUG_GC("lcrec-fina %p\n", b);
466 GC_REGISTER_FINALIZER(b, lcrec_finaliser, NULL, foo, bar);
471 lcrec_register_finaliser(struct lcrecord_header *SXE_UNUSED(b))
475 #endif /* HAVE_BDWGC */
477 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
478 /* lcrecords are chained together through their "next" field.
479 After doing the mark phase, GC will walk this linked list
480 and free any lcrecord which hasn't been marked. */
481 static struct lcrecord_header *all_lcrecords;
485 #if defined USE_MLY_UIDS
486 #define lcheader_set_uid(_x) (_x)->uid = lrecord_uid_counter++
487 #elif defined USE_JWZ_UIDS
488 #define lcheader_set_uid(_x) (_x)->uid = (long int)&(_x)
491 void *alloc_lcrecord(size_t size,
492 const struct lrecord_implementation *implementation)
494 struct lcrecord_header *lcheader;
497 ((implementation->static_size == 0 ?
498 implementation->size_in_bytes_method != NULL :
499 implementation->static_size == size)
500 && (!implementation->basic_p)
502 (!(implementation->hash == NULL
503 && implementation->equal != NULL)));
506 lcheader = (struct lcrecord_header *)allocate_lisp_storage(size);
507 lcrec_register_finaliser(lcheader);
508 set_lheader_implementation(&lcheader->lheader, implementation);
510 lcheader_set_uid(lcheader);
512 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
513 lcheader->next = all_lcrecords;
514 all_lcrecords = lcheader;
515 INCREMENT_CONS_COUNTER(size, implementation->name);
521 static void disksave_object_finalization_1(void)
523 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
524 struct lcrecord_header *header;
526 for (header = all_lcrecords; header; header = header->next) {
527 if (LHEADER_IMPLEMENTATION(&header->lheader)->finalizer &&
529 LHEADER_IMPLEMENTATION(&header->lheader)->
530 finalizer(header, 1);
535 /************************************************************************/
536 /* Debugger support */
537 /************************************************************************/
538 /* Give gdb/dbx enough information to decode Lisp Objects. We make
539 sure certain symbols are always defined, so gdb doesn't complain
540 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
541 to see how this is used. */
543 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
544 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
546 unsigned char dbg_valbits = VALBITS;
547 unsigned char dbg_gctypebits = GCTYPEBITS;
549 /* On some systems, the above definitions will be optimized away by
550 the compiler or linker unless they are referenced in some function. */
551 long dbg_inhibit_dbg_symbol_deletion(void);
552 long dbg_inhibit_dbg_symbol_deletion(void)
554 return (dbg_valmask + dbg_typemask + dbg_valbits + dbg_gctypebits);
557 /* Macros turned into functions for ease of debugging.
558 Debuggers don't know about macros! */
559 int dbg_eq(Lisp_Object obj1, Lisp_Object obj2);
560 int dbg_eq(Lisp_Object obj1, Lisp_Object obj2)
562 return EQ(obj1, obj2);
565 /************************************************************************/
566 /* Fixed-size type macros */
567 /************************************************************************/
569 /* For fixed-size types that are commonly used, we malloc() large blocks
570 of memory at a time and subdivide them into chunks of the correct
571 size for an object of that type. This is more efficient than
572 malloc()ing each object separately because we save on malloc() time
573 and overhead due to the fewer number of malloc()ed blocks, and
574 also because we don't need any extra pointers within each object
575 to keep them threaded together for GC purposes. For less common
576 (and frequently large-size) types, we use lcrecords, which are
577 malloc()ed individually and chained together through a pointer
578 in the lcrecord header. lcrecords do not need to be fixed-size
579 (i.e. two objects of the same type need not have the same size;
580 however, the size of a particular object cannot vary dynamically).
581 It is also much easier to create a new lcrecord type because no
582 additional code needs to be added to alloc.c. Finally, lcrecords
583 may be more efficient when there are only a small number of them.
585 The types that are stored in these large blocks (or "frob blocks")
586 are cons, float, compiled-function, symbol, marker, extent, event,
589 Note that strings are special in that they are actually stored in
590 two parts: a structure containing information about the string, and
591 the actual data associated with the string. The former structure
592 (a struct Lisp_String) is a fixed-size structure and is managed the
593 same way as all the other such types. This structure contains a
594 pointer to the actual string data, which is stored in structures of
595 type struct string_chars_block. Each string_chars_block consists
596 of a pointer to a struct Lisp_String, followed by the data for that
597 string, followed by another pointer to a Lisp_String, followed by
598 the data for that string, etc. At GC time, the data in these
599 blocks is compacted by searching sequentially through all the
600 blocks and compressing out any holes created by unmarked strings.
601 Strings that are more than a certain size (bigger than the size of
602 a string_chars_block, although something like half as big might
603 make more sense) are malloc()ed separately and not stored in
604 string_chars_blocks. Furthermore, no one string stretches across
605 two string_chars_blocks.
607 Vectors are each malloc()ed separately, similar to lcrecords.
609 In the following discussion, we use conses, but it applies equally
610 well to the other fixed-size types.
612 We store cons cells inside of cons_blocks, allocating a new
613 cons_block with malloc() whenever necessary. Cons cells reclaimed
614 by GC are put on a free list to be reallocated before allocating
615 any new cons cells from the latest cons_block. Each cons_block is
616 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
617 the versions in malloc.c and gmalloc.c) really allocates in units
618 of powers of two and uses 4 bytes for its own overhead.
620 What GC actually does is to search through all the cons_blocks,
621 from the most recently allocated to the oldest, and put all
622 cons cells that are not marked (whether or not they're already
623 free) on a cons_free_list. The cons_free_list is a stack, and
624 so the cons cells in the oldest-allocated cons_block end up
625 at the head of the stack and are the first to be reallocated.
626 If any cons_block is entirely free, it is freed with free()
627 and its cons cells removed from the cons_free_list. Because
628 the cons_free_list ends up basically in memory order, we have
629 a high locality of reference (assuming a reasonable turnover
630 of allocating and freeing) and have a reasonable probability
631 of entirely freeing up cons_blocks that have been more recently
632 allocated. This stage is called the "sweep stage" of GC, and
633 is executed after the "mark stage", which involves starting
634 from all places that are known to point to in-use Lisp objects
635 (e.g. the obarray, where are all symbols are stored; the
636 current catches and condition-cases; the backtrace list of
637 currently executing functions; the gcpro list; etc.) and
638 recursively marking all objects that are accessible.
640 At the beginning of the sweep stage, the conses in the cons blocks
641 are in one of three states: in use and marked, in use but not
642 marked, and not in use (already freed). Any conses that are marked
643 have been marked in the mark stage just executed, because as part
644 of the sweep stage we unmark any marked objects. The way we tell
645 whether or not a cons cell is in use is through the LRECORD_FREE_P
646 macro. This uses a special lrecord type `lrecord_type_free',
647 which is never associated with any valid object.
649 Conses on the free_cons_list are threaded through a pointer stored
650 in the conses themselves. Because the cons is still in a
651 cons_block and needs to remain marked as not in use for the next
652 time that GC happens, we need room to store both the "free"
653 indicator and the chaining pointer. So this pointer is stored
654 after the lrecord header (actually where C places a pointer after
655 the lrecord header; they are not necessarily contiguous). This
656 implies that all fixed-size types must be big enough to contain at
657 least one pointer. This is true for all current fixed-size types,
658 with the possible exception of Lisp_Floats, for which we define the
659 meat of the struct using a union of a pointer and a double to
660 ensure adequate space for the free list chain pointer.
662 Some types of objects need additional "finalization" done
663 when an object is converted from in use to not in use;
664 this is the purpose of the ADDITIONAL_FREE_type macro.
665 For example, markers need to be removed from the chain
666 of markers that is kept in each buffer. This is because
667 markers in a buffer automatically disappear if the marker
668 is no longer referenced anywhere (the same does not
669 apply to extents, however).
671 WARNING: Things are in an extremely bizarre state when
672 the ADDITIONAL_FREE_type macros are called, so beware!
674 When ERROR_CHECK_GC is defined, we do things differently so as to
675 maximize our chances of catching places where there is insufficient
676 GCPROing. The thing we want to avoid is having an object that
677 we're using but didn't GCPRO get freed by GC and then reallocated
678 while we're in the process of using it -- this will result in
679 something seemingly unrelated getting trashed, and is extremely
680 difficult to track down. If the object gets freed but not
681 reallocated, we can usually catch this because we set most of the
682 bytes of a freed object to 0xDEADBEEF. (The lisp object type is set
683 to the invalid type `lrecord_type_free', however, and a pointer
684 used to chain freed objects together is stored after the lrecord
685 header; we play some tricks with this pointer to make it more
686 bogus, so crashes are more likely to occur right away.)
688 We want freed objects to stay free as long as possible,
689 so instead of doing what we do above, we maintain the
690 free objects in a first-in first-out queue. We also
691 don't recompute the free list each GC, unlike above;
692 this ensures that the queue ordering is preserved.
693 [This means that we are likely to have worse locality
694 of reference, and that we can never free a frob block
695 once it's allocated. (Even if we know that all cells
696 in it are free, there's no easy way to remove all those
697 cells from the free list because the objects on the
698 free list are unlikely to be in memory order.)]
699 Furthermore, we never take objects off the free list
700 unless there's a large number (usually 1000, but
701 varies depending on type) of them already on the list.
702 This way, we ensure that an object that gets freed will
703 remain free for the next 1000 (or whatever) times that
704 an object of that type is allocated. */
706 #ifndef MALLOC_OVERHEAD
708 #define MALLOC_OVERHEAD 0
709 #elif defined (rcheck)
710 #define MALLOC_OVERHEAD 20
712 #define MALLOC_OVERHEAD 8
714 #endif /* MALLOC_OVERHEAD */
716 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
717 /* If we released our reserve (due to running out of memory),
718 and we have a fair amount free once again,
719 try to set aside another reserve in case we run out once more.
721 This is called when a relocatable block is freed in ralloc.c. */
722 void refill_memory_reserve(void);
723 void refill_memory_reserve(void)
725 if (breathing_space == NULL) {
726 breathing_space = malloc(0xFFFF - MALLOC_OVERHEAD);
729 #endif /* !HAVE_MMAP || DOUG_LEA_MALLOC */
731 #ifdef ALLOC_NO_POOLS
732 # define TYPE_ALLOC_SIZE(type, structtype) 1
734 # define TYPE_ALLOC_SIZE(type, structtype) \
735 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
736 / sizeof (structtype))
737 #endif /* ALLOC_NO_POOLS */
739 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
740 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
742 init_##type##_alloc(void) \
747 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
749 struct type##_block \
751 struct type##_block *prev; \
752 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
755 static struct type##_block *current_##type##_block; \
756 static int current_##type##_block_index; \
758 static Lisp_Free *type##_free_list; \
759 static Lisp_Free *type##_free_list_tail; \
762 init_##type##_alloc (void) \
764 current_##type##_block = 0; \
765 current_##type##_block_index = \
766 countof (current_##type##_block->block); \
767 type##_free_list = 0; \
768 type##_free_list_tail = 0; \
771 static int gc_count_num_##type##_in_use; \
772 static int gc_count_num_##type##_freelist
773 #endif /* HAVE_BDWGC */
775 /* no need for a case distinction, shouldn't be called in bdwgc mode */
776 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) \
778 if (current_##type##_block_index \
779 == countof (current_##type##_block->block)) { \
780 struct type##_block *AFTFB_new = \
781 (struct type##_block *) \
782 allocate_lisp_storage( \
783 sizeof (struct type##_block)); \
784 AFTFB_new->prev = current_##type##_block; \
785 current_##type##_block = AFTFB_new; \
786 current_##type##_block_index = 0; \
788 (result) = &(current_##type##_block \
789 ->block[current_##type##_block_index++]); \
792 /* Allocate an instance of a type that is stored in blocks.
793 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
796 #ifdef ERROR_CHECK_GC
798 /* Note: if you get crashes in this function, suspect incorrect calls
799 to free_cons() and friends. This happened once because the cons
800 cell was not GC-protected and was getting collected before
801 free_cons() was called. */
803 /* no need for a case distinction, shouldn't be called in bdwgc mode */
804 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
807 if (gc_count_num_##type##_freelist > \
808 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) { \
809 result = (structtype *) type##_free_list; \
810 /* Before actually using the chain pointer, \
811 we complement all its bits; \
812 see FREE_FIXED_TYPE(). */ \
813 type##_free_list = (Lisp_Free *) \
815 (type##_free_list->chain)); \
816 gc_count_num_##type##_freelist--; \
818 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
820 MARK_LRECORD_AS_NOT_FREE (result); \
821 unlock_allocator(); \
824 #else /* !ERROR_CHECK_GC */
826 /* no need for a case distinction, shouldn't be called in bdwgc mode */
827 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
829 if (type##_free_list) { \
830 result = (structtype *) type##_free_list; \
831 type##_free_list = type##_free_list->chain; \
833 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
835 MARK_LRECORD_AS_NOT_FREE (result); \
837 #endif /* !ERROR_CHECK_GC */
839 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
841 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
843 result = xnew(structtype); \
844 assert(result != NULL); \
845 INCREMENT_CONS_COUNTER(sizeof(structtype), #type); \
847 #define ALLOCATE_ATOMIC_FIXED_TYPE(type, structtype, result) \
849 result = xnew_atomic(structtype); \
850 assert(result != NULL); \
851 INCREMENT_CONS_COUNTER(sizeof(structtype), #type); \
856 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
858 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
859 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
861 #define ALLOCATE_ATOMIC_FIXED_TYPE ALLOCATE_FIXED_TYPE
865 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
866 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
867 (result) = xnew(structtype)
869 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
871 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
872 NOSEEUM_INCREMENT_CONS_COUNTER(sizeof (structtype), #type); \
876 /* Lisp_Free is the type to represent a free list member inside a frob
877 block of any lisp object type. */
878 typedef struct Lisp_Free {
879 struct lrecord_header lheader;
880 struct Lisp_Free *chain;
883 #define LRECORD_FREE_P(ptr) \
884 ((ptr)->lheader.type == lrecord_type_free)
886 #define MARK_LRECORD_AS_FREE(ptr) \
887 ((void) ((ptr)->lheader.type = lrecord_type_free))
889 #ifdef ERROR_CHECK_GC
890 #define MARK_LRECORD_AS_NOT_FREE(ptr) \
891 ((void) ((ptr)->lheader.type = lrecord_type_undefined))
893 #define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING
896 #ifdef ERROR_CHECK_GC
898 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
900 if (type##_free_list_tail) { \
901 /* When we store the chain pointer, we \
902 complement all its bits; this should \
903 significantly increase its bogosity in case \
904 someone tries to use the value, and \
905 should make us crash faster if someone \
906 overwrites the pointer because when it gets \
907 un-complemented in ALLOCATED_FIXED_TYPE(), \
908 the resulting pointer will be extremely \
910 type##_free_list_tail->chain = \
911 (Lisp_Free *) ~ (EMACS_UINT) (ptr); \
913 type##_free_list = (Lisp_Free *) (ptr); \
915 type##_free_list_tail = (Lisp_Free *) (ptr); \
918 #else /* !ERROR_CHECK_GC */
920 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
922 ((Lisp_Free *) (ptr))->chain = type##_free_list; \
923 type##_free_list = (Lisp_Free *) (ptr); \
926 #endif /* !ERROR_CHECK_GC */
928 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
930 #define FREE_FIXED_TYPE(type, structtype, ptr) \
932 structtype *FFT_ptr = (ptr); \
933 ADDITIONAL_FREE_##type (FFT_ptr); \
934 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
935 PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, FFT_ptr); \
936 MARK_LRECORD_AS_FREE (FFT_ptr); \
939 /* Like FREE_FIXED_TYPE() but used when we are explicitly
940 freeing a structure through free_cons(), free_marker(), etc.
941 rather than through the normal process of sweeping.
942 We attempt to undo the changes made to the allocation counters
943 as a result of this structure being allocated. This is not
944 completely necessary but helps keep things saner: e.g. this way,
945 repeatedly allocating and freeing a cons will not result in
946 the consing-since-gc counter advancing, which would cause a GC
947 and somewhat defeat the purpose of explicitly freeing. */
949 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
950 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr)
951 #else /* !HAVE_BDWGC */
952 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
954 FREE_FIXED_TYPE (type, structtype, ptr); \
955 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
956 gc_count_num_##type##_freelist++; \
958 #endif /* HAVE_BDWGC */
960 /************************************************************************/
961 /* Cons allocation */
962 /************************************************************************/
964 DECLARE_FIXED_TYPE_ALLOC(cons, Lisp_Cons);
965 /* conses are used and freed so often that we set this really high */
966 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
967 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
969 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
971 cons_register_finaliser(Lisp_Cons *s)
973 GC_finalization_proc *foo = NULL;
975 auto void cons_finaliser();
977 auto void cons_finaliser(void *obj, void *SXE_UNUSED(data))
980 memset(obj, 0, sizeof(Lisp_Cons));
984 SXE_DEBUG_GC("cons-fina %p\n", s);
985 GC_REGISTER_FINALIZER(s, cons_finaliser, NULL, foo, bar);
990 cons_register_finaliser(Lisp_Cons *SXE_UNUSED(b))
994 #endif /* HAVE_BDWGC */
996 static Lisp_Object mark_cons(Lisp_Object obj)
1001 mark_object(XCAR(obj));
1005 static int cons_equal(Lisp_Object ob1, Lisp_Object ob2, int depth)
1008 while (internal_equal(XCAR(ob1), XCAR(ob2), depth)) {
1011 if (!CONSP(ob1) || !CONSP(ob2))
1012 return internal_equal(ob1, ob2, depth);
1017 /* the seq approach for conses */
1019 cons_length(const seq_t cons)
1022 GET_EXTERNAL_LIST_LENGTH((Lisp_Object)cons, len);
1027 cons_iter_init(seq_t cons, seq_iter_t si)
1029 si->data = si->seq = cons;
1034 cons_iter_next(seq_iter_t si, void **elt)
1036 if (si->data != NULL && CONSP(si->data)) {
1037 *elt = (void*)((Lisp_Cons*)si->data)->car;
1038 si->data = (void*)((Lisp_Cons*)si->data)->cdr;
1046 cons_iter_fini(seq_iter_t si)
1048 si->data = si->seq = NULL;
1053 cons_iter_reset(seq_iter_t si)
1060 cons_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
1062 volatile size_t i = 0;
1063 volatile Lisp_Object c = (Lisp_Object)s;
1065 while (CONSP(c) && i < ntgt) {
1066 tgt[i++] = (void*)XCAR(c);
1072 static struct seq_impl_s __scons = {
1073 .length_f = cons_length,
1074 .iter_init_f = cons_iter_init,
1075 .iter_next_f = cons_iter_next,
1076 .iter_fini_f = cons_iter_fini,
1077 .iter_reset_f = cons_iter_reset,
1078 .explode_f = cons_explode,
1081 static const struct lrecord_description cons_description[] = {
1082 {XD_LISP_OBJECT, offsetof(Lisp_Cons, car)},
1083 {XD_LISP_OBJECT, offsetof(Lisp_Cons, cdr)},
1087 DEFINE_BASIC_LRECORD_IMPLEMENTATION("cons", cons,
1088 mark_cons, print_cons, 0, cons_equal,
1090 * No `hash' method needed.
1091 * internal_hash knows how to
1094 0, cons_description, Lisp_Cons);
1096 DEFUN("cons", Fcons, 2, 2, 0, /*
1097 Create a new cons, give it CAR and CDR as components, and return it.
1099 A cons cell is a Lisp object (an area in memory) made up of two pointers
1100 called the CAR and the CDR. Each of these pointers can point to any other
1101 Lisp object. The common Lisp data type, the list, is a specially-structured
1102 series of cons cells.
1104 The pointers are accessed from Lisp with `car' and `cdr', and mutated with
1105 `setcar' and `setcdr' respectively. For historical reasons, the aliases
1106 `rplaca' and `rplacd' (for `setcar' and `setcdr') are supported.
1110 /* This cannot GC. */
1114 ALLOCATE_FIXED_TYPE(cons, Lisp_Cons, c);
1115 set_lheader_implementation(&c->lheader, &lrecord_cons);
1116 cons_register_finaliser(c);
1120 /* propagate the cat system, go with the standard impl of a seq first */
1121 c->lheader.morphisms = 0;
1125 /* This is identical to Fcons() but it used for conses that we're
1126 going to free later, and is useful when trying to track down
1128 Lisp_Object noseeum_cons(Lisp_Object car, Lisp_Object cdr)
1133 NOSEEUM_ALLOCATE_FIXED_TYPE(cons, Lisp_Cons, c);
1134 set_lheader_implementation(&c->lheader, &lrecord_cons);
1138 /* propagate the cat system, go with the standard impl of a seq first */
1139 c->lheader.morphisms = 0;
1143 DEFUN("list", Flist, 0, MANY, 0, /*
1144 Return a newly created list with specified arguments as elements.
1145 Any number of arguments, even zero arguments, are allowed.
1147 (int nargs, Lisp_Object * args))
1149 Lisp_Object val = Qnil;
1150 Lisp_Object *argp = args + nargs;
1153 val = Fcons(*--argp, val);
1157 Lisp_Object list1(Lisp_Object obj0)
1159 /* This cannot GC. */
1160 return Fcons(obj0, Qnil);
1163 Lisp_Object list2(Lisp_Object obj0, Lisp_Object obj1)
1165 /* This cannot GC. */
1166 return Fcons(obj0, Fcons(obj1, Qnil));
1169 Lisp_Object list3(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1171 /* This cannot GC. */
1172 return Fcons(obj0, Fcons(obj1, Fcons(obj2, Qnil)));
1175 Lisp_Object cons3(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1177 /* This cannot GC. */
1178 return Fcons(obj0, Fcons(obj1, obj2));
1181 Lisp_Object acons(Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1183 return Fcons(Fcons(key, value), alist);
1187 list4(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1189 /* This cannot GC. */
1190 return Fcons(obj0, Fcons(obj1, Fcons(obj2, Fcons(obj3, Qnil))));
1194 list5(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1197 /* This cannot GC. */
1199 Fcons(obj1, Fcons(obj2, Fcons(obj3, Fcons(obj4, Qnil)))));
1203 list6(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1204 Lisp_Object obj4, Lisp_Object obj5)
1206 /* This cannot GC. */
1210 Fcons(obj3, Fcons(obj4, Fcons(obj5, Qnil))))));
1213 DEFUN("make-list", Fmake_list, 2, 2, 0, /*
1214 Return a new list of length LENGTH, with each element being OBJECT.
1218 CHECK_NATNUM(length);
1221 Lisp_Object val = Qnil;
1222 size_t size = XINT(length);
1225 val = Fcons(object, val);
1230 /************************************************************************/
1231 /* Float allocation */
1232 /************************************************************************/
1233 /* used by many of the allocators below */
1234 #include "ent/ent.h"
1239 DECLARE_FIXED_TYPE_ALLOC(float, Lisp_Float);
1240 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1242 Lisp_Object make_float(fpfloat float_value)
1247 if (ENT_FLOAT_PINF_P(float_value))
1248 return make_indef(POS_INFINITY);
1249 else if (ENT_FLOAT_NINF_P(float_value))
1250 return make_indef(NEG_INFINITY);
1251 else if (ENT_FLOAT_NAN_P(float_value))
1252 return make_indef(NOT_A_NUMBER);
1254 ALLOCATE_FIXED_TYPE(float, Lisp_Float, f);
1256 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1257 if (sizeof(struct lrecord_header) +
1258 sizeof(fpfloat) != sizeof(*f))
1261 set_lheader_implementation(&f->lheader, &lrecord_float);
1262 float_data(f) = float_value;
1267 #endif /* HAVE_FPFLOAT */
1269 /************************************************************************/
1270 /* Enhanced number allocation */
1271 /************************************************************************/
1274 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1275 DECLARE_FIXED_TYPE_ALLOC(bigz, Lisp_Bigz);
1276 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigz 250
1278 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1280 bigz_register_finaliser(Lisp_Bigz *b)
1282 GC_finalization_proc *foo = NULL;
1284 auto void bigz_finaliser();
1286 auto void bigz_finaliser(void *obj, void *SXE_UNUSED(data))
1288 bigz_fini(bigz_data((Lisp_Bigz*)obj));
1290 memset(obj, 0, sizeof(Lisp_Bigz));
1294 GC_REGISTER_FINALIZER(b, bigz_finaliser, NULL, foo, bar);
1299 bigz_register_finaliser(Lisp_Bigz *SXE_UNUSED(b))
1303 #endif /* HAVE_BDWGC */
1305 /* WARNING: This function returns a bignum even if its argument fits into a
1306 fixnum. See Fcanonicalize_number(). */
1308 make_bigz (long bigz_value)
1312 ALLOCATE_FIXED_TYPE(bigz, Lisp_Bigz, b);
1313 bigz_register_finaliser(b);
1315 set_lheader_implementation(&b->lheader, &lrecord_bigz);
1316 bigz_init(bigz_data(b));
1317 bigz_set_long(bigz_data(b), bigz_value);
1318 return wrap_bigz(b);
1321 /* WARNING: This function returns a bigz even if its argument fits into a
1322 fixnum. See Fcanonicalize_number(). */
1324 make_bigz_bz (bigz bz)
1328 ALLOCATE_FIXED_TYPE(bigz, Lisp_Bigz, b);
1329 bigz_register_finaliser(b);
1331 set_lheader_implementation(&b->lheader, &lrecord_bigz);
1332 bigz_init(bigz_data(b));
1333 bigz_set(bigz_data(b), bz);
1334 return wrap_bigz(b);
1336 #endif /* HAVE_MPZ */
1339 #if defined HAVE_MPQ && defined WITH_GMP
1340 DECLARE_FIXED_TYPE_ALLOC(bigq, Lisp_Bigq);
1341 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigq 250
1343 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1345 bigq_register_finaliser(Lisp_Bigq *b)
1347 GC_finalization_proc *foo = NULL;
1349 auto void bigq_finaliser();
1351 auto void bigq_finaliser(void *obj, void *SXE_UNUSED(data))
1353 bigq_fini(bigq_data((Lisp_Bigq*)obj));
1355 memset(obj, 0, sizeof(Lisp_Bigq));
1359 GC_REGISTER_FINALIZER(b, bigq_finaliser, NULL, foo, bar);
1364 bigq_register_finaliser(Lisp_Bigq *SXE_UNUSED(b))
1368 #endif /* HAVE_BDWGC */
1371 make_bigq(long numerator, unsigned long denominator)
1375 ALLOCATE_FIXED_TYPE(bigq, Lisp_Bigq, r);
1376 bigq_register_finaliser(r);
1378 set_lheader_implementation(&r->lheader, &lrecord_bigq);
1379 bigq_init(bigq_data(r));
1380 bigq_set_long_ulong(bigq_data(r), numerator, denominator);
1381 bigq_canonicalize(bigq_data(r));
1382 return wrap_bigq(r);
1386 make_bigq_bz(bigz numerator, bigz denominator)
1390 ALLOCATE_FIXED_TYPE(bigq, Lisp_Bigq, r);
1391 bigq_register_finaliser(r);
1393 set_lheader_implementation(&r->lheader, &lrecord_bigq);
1394 bigq_init(bigq_data(r));
1395 bigq_set_bigz_bigz(bigq_data(r), numerator, denominator);
1396 bigq_canonicalize(bigq_data(r));
1397 return wrap_bigq(r);
1401 make_bigq_bq(bigq rat)
1405 ALLOCATE_FIXED_TYPE(bigq, Lisp_Bigq, r);
1406 bigq_register_finaliser(r);
1408 set_lheader_implementation(&r->lheader, &lrecord_bigq);
1409 bigq_init(bigq_data(r));
1410 bigq_set(bigq_data(r), rat);
1411 return wrap_bigq(r);
1413 #endif /* HAVE_MPQ */
1416 #if defined HAVE_MPF && defined WITH_GMP
1417 DECLARE_FIXED_TYPE_ALLOC(bigf, Lisp_Bigf);
1418 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigf 250
1420 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1422 bigf_register_finaliser(Lisp_Bigf *b)
1424 GC_finalization_proc *foo = NULL;
1426 auto void bigf_finaliser();
1428 auto void bigf_finaliser(void *obj, void *SXE_UNUSED(data))
1430 bigf_fini(bigf_data((Lisp_Bigf*)obj));
1432 memset(obj, 0, sizeof(Lisp_Bigf));
1436 GC_REGISTER_FINALIZER(b, bigf_finaliser, NULL, foo, bar);
1441 bigf_register_finaliser(Lisp_Bigf *SXE_UNUSED(b))
1445 #endif /* HAVE_BDWGC */
1447 /* This function creates a bigfloat with the default precision if the
1448 PRECISION argument is zero. */
1450 make_bigf(fpfloat float_value, unsigned long precision)
1454 ALLOCATE_FIXED_TYPE(bigf, Lisp_Bigf, f);
1455 bigf_register_finaliser(f);
1457 set_lheader_implementation(&f->lheader, &lrecord_bigf);
1458 if (precision == 0UL)
1459 bigf_init(bigf_data(f));
1461 bigf_init_prec(bigf_data(f), precision);
1462 bigf_set_fpfloat(bigf_data(f), float_value);
1463 return wrap_bigf(f);
1466 /* This function creates a bigfloat with the precision of its argument */
1468 make_bigf_bf(bigf float_value)
1472 ALLOCATE_FIXED_TYPE(bigf, Lisp_Bigf, f);
1473 bigf_register_finaliser(f);
1475 set_lheader_implementation(&f->lheader, &lrecord_bigf);
1476 bigf_init_prec(bigf_data(f), bigf_get_prec(float_value));
1477 bigf_set(bigf_data(f), float_value);
1478 return wrap_bigf(f);
1480 #endif /* HAVE_MPF */
1482 /*** Bigfloat with correct rounding ***/
1483 #if defined HAVE_MPFR && defined WITH_MPFR
1484 DECLARE_FIXED_TYPE_ALLOC(bigfr, Lisp_Bigfr);
1485 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigfr 250
1487 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1489 bigfr_register_finaliser(Lisp_Bigfr *b)
1491 GC_finalization_proc *foo = NULL;
1493 auto void bigfr_finaliser();
1495 auto void bigfr_finaliser(void *obj, void *SXE_UNUSED(data))
1497 bigfr_fini(bigfr_data((Lisp_Bigfr*)obj));
1499 memset(obj, 0, sizeof(Lisp_Bigfr));
1503 GC_REGISTER_FINALIZER(b, bigfr_finaliser, NULL, foo, bar);
1508 bigfr_register_finaliser(Lisp_Bigfr *SXE_UNUSED(b))
1512 #endif /* HAVE_BDWGC */
1514 /* This function creates a bigfloat with the default precision if the
1515 PRECISION argument is zero. */
1517 make_bigfr(fpfloat float_value, unsigned long precision)
1521 ALLOCATE_FIXED_TYPE(bigfr, Lisp_Bigfr, f);
1522 set_lheader_implementation(&f->lheader, &lrecord_bigfr);
1523 bigfr_register_finaliser(f);
1525 if (precision == 0UL) {
1526 bigfr_init(bigfr_data(f));
1528 bigfr_init_prec(bigfr_data(f), precision);
1530 bigfr_set_fpfloat(bigfr_data(f), float_value);
1531 return wrap_bigfr(f);
1534 /* This function creates a bigfloat with the precision of its argument */
1536 make_bigfr_bf(bigf float_value)
1540 ALLOCATE_FIXED_TYPE(bigfr, Lisp_Bigfr, f);
1541 set_lheader_implementation(&f->lheader, &lrecord_bigfr);
1542 bigfr_register_finaliser(f);
1544 bigfr_init_prec(bigfr_data(f), bigf_get_prec(float_value));
1545 bigfr_set_bigf(bigfr_data(f), float_value);
1546 return wrap_bigfr(f);
1549 /* This function creates a bigfloat with the precision of its argument */
1551 make_bigfr_bfr(bigfr bfr_value)
1555 if (bigfr_nan_p(bfr_value) || bigfr_inf_p(bfr_value)) {
1556 return make_indef_bfr(bfr_value);
1559 ALLOCATE_FIXED_TYPE(bigfr, Lisp_Bigfr, f);
1560 set_lheader_implementation(&f->lheader, &lrecord_bigfr);
1561 bigfr_register_finaliser(f);
1563 bigfr_init_prec(bigfr_data(f), bigfr_get_prec(bfr_value));
1564 bigfr_set(bigfr_data(f), bfr_value);
1565 return wrap_bigfr(f);
1567 #endif /* HAVE_MPFR */
1569 /*** Big gaussian numbers ***/
1570 #if defined HAVE_PSEUG && defined HAVE_MPZ && defined WITH_PSEUG
1571 DECLARE_FIXED_TYPE_ALLOC(bigg, Lisp_Bigg);
1572 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigg 250
1574 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1576 bigg_register_finaliser(Lisp_Bigg *b)
1578 GC_finalization_proc *foo = NULL;
1580 auto void bigg_finaliser();
1582 auto void bigg_finaliser(void *obj, void *SXE_UNUSED(data))
1584 bigg_fini(bigg_data((Lisp_Bigg*)obj));
1586 memset(obj, 0, sizeof(Lisp_Bigg));
1590 GC_REGISTER_FINALIZER(b, bigg_finaliser, NULL, foo, bar);
1595 bigg_register_finaliser(Lisp_Bigg *SXE_UNUSED(b))
1599 #endif /* HAVE_BDWGC */
1601 /* This function creates a gaussian number. */
1603 make_bigg(long intg, long imag)
1607 ALLOCATE_FIXED_TYPE(bigg, Lisp_Bigg, g);
1608 set_lheader_implementation(&g->lheader, &lrecord_bigg);
1609 bigg_register_finaliser(g);
1611 bigg_init(bigg_data(g));
1612 bigg_set_long_long(bigg_data(g), intg, imag);
1613 return wrap_bigg(g);
1616 /* This function creates a complex with the precision of its argument */
1618 make_bigg_bz(bigz intg, bigz imag)
1622 ALLOCATE_FIXED_TYPE(bigg, Lisp_Bigg, g);
1623 set_lheader_implementation(&g->lheader, &lrecord_bigg);
1624 bigg_register_finaliser(g);
1626 bigg_init(bigg_data(g));
1627 bigg_set_bigz_bigz(bigg_data(g), intg, imag);
1628 return wrap_bigg(g);
1631 /* This function creates a complex with the precision of its argument */
1633 make_bigg_bg(bigg gaussian_value)
1637 ALLOCATE_FIXED_TYPE(bigg, Lisp_Bigg, g);
1638 set_lheader_implementation(&g->lheader, &lrecord_bigg);
1639 bigg_register_finaliser(g);
1641 bigg_init(bigg_data(g));
1642 bigg_set(bigg_data(g), gaussian_value);
1643 return wrap_bigg(g);
1645 #endif /* HAVE_PSEUG */
1647 /*** Big complex numbers with correct rounding ***/
1648 #if defined HAVE_MPC && defined WITH_MPC || \
1649 defined HAVE_PSEUC && defined WITH_PSEUC
1650 DECLARE_FIXED_TYPE_ALLOC(bigc, Lisp_Bigc);
1651 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigc 250
1653 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1655 bigc_register_finaliser(Lisp_Bigc *b)
1657 GC_finalization_proc *foo = NULL;
1659 auto void bigc_finaliser();
1661 auto void bigc_finaliser(void *obj, void *SXE_UNUSED(data))
1663 bigc_fini(bigc_data((Lisp_Bigc*)obj));
1665 memset(obj, 0, sizeof(Lisp_Bigc));
1669 GC_REGISTER_FINALIZER(b, bigc_finaliser, NULL, foo, bar);
1674 bigc_register_finaliser(Lisp_Bigc *SXE_UNUSED(b))
1678 #endif /* HAVE_BDWGC */
1680 /* This function creates a bigfloat with the default precision if the
1681 PRECISION argument is zero. */
1683 make_bigc(fpfloat re_value, fpfloat im_value, unsigned long precision)
1687 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1688 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1689 bigc_register_finaliser(c);
1691 if (precision == 0UL) {
1692 bigc_init(bigc_data(c));
1694 bigc_init_prec(bigc_data(c), precision);
1696 bigc_set_fpfloat_fpfloat(bigc_data(c), re_value, im_value);
1697 return wrap_bigc(c);
1700 /* This function creates a complex with the precision of its argument */
1702 make_bigc_bfr(bigfr re_value, bigfr im_value, unsigned long precision)
1706 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1707 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1708 bigc_register_finaliser(c);
1710 if (precision == 0UL) {
1711 bigc_init(bigc_data(c));
1713 bigc_init_prec(bigc_data(c), precision);
1715 bigc_set_bigfr_bigfr(bigc_data(c), re_value, im_value);
1716 return wrap_bigc(c);
1719 /* This function creates a complex with the precision of its argument */
1721 make_bigc_bc(bigc complex_value)
1725 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1726 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1727 bigc_register_finaliser(c);
1729 bigc_init_prec(bigc_data(c), bigc_get_prec(complex_value));
1730 bigc_set(bigc_data(c), complex_value);
1731 return wrap_bigc(c);
1733 #endif /* HAVE_MPC */
1735 /*** Quaternions ***/
1736 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
1737 DECLARE_FIXED_TYPE_ALLOC(quatern, Lisp_Quatern);
1738 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_quatern 250
1740 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1742 quatern_register_finaliser(Lisp_Quatern *b)
1744 GC_finalization_proc *foo = NULL;
1746 auto void quatern_finaliser();
1748 auto void quatern_finaliser(void *obj, void *SXE_UNUSED(data))
1750 quatern_fini(quatern_data((Lisp_Quatern*)obj));
1752 memset(obj, 0, sizeof(Lisp_Quatern));
1756 GC_REGISTER_FINALIZER(b, quatern_finaliser, NULL, foo, bar);
1761 quatern_register_finaliser(Lisp_Quatern *SXE_UNUSED(b))
1765 #endif /* HAVE_BDWGC */
1767 /* This function creates a quaternion. */
1769 make_quatern(EMACS_INT z, EMACS_INT i, EMACS_INT j, EMACS_INT k)
1773 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1774 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1775 quatern_register_finaliser(g);
1777 quatern_init(quatern_data(g));
1778 quatern_set_long_long_long_long(quatern_data(g), z, i, j, k);
1779 return wrap_quatern(g);
1783 make_quatern_bz(bigz z, bigz i, bigz j, bigz k)
1787 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1788 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1789 quatern_register_finaliser(g);
1791 quatern_init(quatern_data(g));
1792 quatern_set_bigz_bigz_bigz_bigz(quatern_data(g), z, i, j, k);
1793 return wrap_quatern(g);
1797 make_quatern_qu(quatern quaternion)
1801 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1802 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1803 quatern_register_finaliser(g);
1805 quatern_init(quatern_data(g));
1806 quatern_set(quatern_data(g), quaternion);
1807 return wrap_quatern(g);
1809 #endif /* HAVE_QUATERN */
1812 make_indef_internal(indef sym)
1816 i = allocate_lisp_storage(sizeof(Lisp_Indef));
1817 set_lheader_implementation(&i->lheader, &lrecord_indef);
1818 indef_data(i) = sym;
1819 return wrap_indef(i);
1823 make_indef(indef sym)
1830 case COMPLEX_INFINITY:
1831 return Vcomplex_infinity;
1834 /* list some more here */
1835 case END_OF_COMPARABLE_INFINITIES:
1836 case END_OF_INFINITIES:
1838 return Vnot_a_number;
1842 #if defined HAVE_MPFR && defined WITH_MPFR
1844 make_indef_bfr(bigfr bfr_value)
1846 if (bigfr_nan_p(bfr_value)) {
1847 return make_indef(NOT_A_NUMBER);
1848 } else if (bigfr_inf_p(bfr_value)) {
1849 if (bigfr_sign(bfr_value) > 0)
1850 return make_indef(POS_INFINITY);
1852 return make_indef(NEG_INFINITY);
1854 return make_indef(NOT_A_NUMBER);
1859 DECLARE_FIXED_TYPE_ALLOC(dynacat, struct dynacat_s);
1860 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_dynacat 1000
1862 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
1864 dynacat_register_finaliser(dynacat_t b)
1866 GC_finalization_proc *foo = NULL;
1868 auto void dynacat_finaliser();
1870 auto void dynacat_finaliser(void *obj, void *SXE_UNUSED(data))
1872 SXE_DEBUG_GC("calling dynacat finaliser on %p\n", obj);
1875 memset(obj, 0, sizeof(struct dynacat_s));
1879 SXE_DEBUG_GC("dynacat-fina %p\n", b);
1880 GC_REGISTER_FINALIZER(b, dynacat_finaliser, NULL, foo, bar);
1885 dynacat_register_finaliser(dynacat_t SXE_UNUSED(b))
1889 #endif /* HAVE_BDWGC */
1892 make_dynacat(void *ptr)
1896 ALLOCATE_FIXED_TYPE(dynacat, struct dynacat_s, emp);
1897 dynacat_register_finaliser(emp);
1898 set_lheader_implementation(&emp->lheader, &lrecord_dynacat);
1901 emp->intprfun = NULL;
1908 return wrap_object(emp);
1912 /************************************************************************/
1913 /* Vector allocation */
1914 /************************************************************************/
1916 static Lisp_Object mark_vector(Lisp_Object obj)
1918 Lisp_Vector *ptr = XVECTOR(obj);
1919 int len = vector_length(ptr);
1922 for (i = 0; i < len - 1; i++)
1923 mark_object(ptr->contents[i]);
1924 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1927 static size_t size_vector(const void *lheader)
1929 return FLEXIBLE_ARRAY_STRUCT_SIZEOF(
1930 Lisp_Vector, Lisp_Object, contents,
1931 ((const Lisp_Vector*)lheader)->size);
1934 static int vector_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
1936 int len = XVECTOR_LENGTH(obj1);
1937 if (len != XVECTOR_LENGTH(obj2))
1941 Lisp_Object *ptr1 = XVECTOR_DATA(obj1);
1942 Lisp_Object *ptr2 = XVECTOR_DATA(obj2);
1944 if (!internal_equal(*ptr1++, *ptr2++, depth + 1))
1950 static hcode_t vector_hash(Lisp_Object obj, int depth)
1952 return HASH2(XVECTOR_LENGTH(obj),
1953 internal_array_hash(XVECTOR_DATA(obj),
1954 XVECTOR_LENGTH(obj), depth + 1));
1957 /* the seq approach for conses */
1959 vec_length(const seq_t v)
1961 return XVECTOR_LENGTH((Lisp_Object)(long int)v);
1965 vec_iter_init(seq_t v, seq_iter_t si)
1968 si->data = (void*)0;
1973 vec_iter_next(seq_iter_t si, void **elt)
1975 if (si->seq != NULL &&
1976 (long int)si->data < ((Lisp_Vector*)si->seq)->size) {
1977 *elt = (void*)vector_data((Lisp_Vector*)si->seq)
1978 [(long int)si->data];
1979 si->data = (void*)((long int)si->data + 1L);
1987 vec_iter_fini(seq_iter_t si)
1989 si->data = si->seq = NULL;
1994 vec_iter_reset(seq_iter_t si)
1996 si->data = (void*)0;
2001 vec_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
2003 size_t len = vector_length((const Lisp_Vector*)s);
2004 volatile size_t i = 0;
2006 while (i < len && i < ntgt) {
2007 tgt[i] = (void*)vector_data((const Lisp_Vector*)s)[i];
2013 static struct seq_impl_s __svec = {
2014 .length_f = vec_length,
2015 .iter_init_f = vec_iter_init,
2016 .iter_next_f = vec_iter_next,
2017 .iter_fini_f = vec_iter_fini,
2018 .iter_reset_f = vec_iter_reset,
2019 .explode_f = vec_explode,
2022 static const struct lrecord_description vector_description[] = {
2023 {XD_LONG, offsetof(Lisp_Vector, size)},
2024 {XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Vector, contents),
2029 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
2030 mark_vector, print_vector, 0,
2034 size_vector, Lisp_Vector);
2036 /* #### should allocate `small' vectors from a frob-block */
2037 static Lisp_Vector *make_vector_internal(size_t sizei)
2039 /* no vector_next */
2040 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Vector, Lisp_Object,
2042 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord(sizem, &lrecord_vector);
2045 p->header.lheader.morphisms = (1<<cat_mk_lc);
2049 Lisp_Object make_vector(size_t length, Lisp_Object object)
2051 Lisp_Vector *vecp = make_vector_internal(length);
2052 Lisp_Object *p = vector_data(vecp);
2059 XSETVECTOR(vector, vecp);
2064 DEFUN("make-vector", Fmake_vector, 2, 2, 0, /*
2065 Return a new vector of length LENGTH, with each element being OBJECT.
2066 See also the function `vector'.
2070 CONCHECK_NATNUM(length);
2071 return make_vector(XINT(length), object);
2074 DEFUN("vector", Fvector, 0, MANY, 0, /*
2075 Return a newly created vector with specified arguments as elements.
2076 Any number of arguments, even zero arguments, are allowed.
2078 (int nargs, Lisp_Object * args))
2080 Lisp_Vector *vecp = make_vector_internal(nargs);
2081 Lisp_Object *p = vector_data(vecp);
2088 XSETVECTOR(vector, vecp);
2093 Lisp_Object vector1(Lisp_Object obj0)
2095 return Fvector(1, &obj0);
2098 Lisp_Object vector2(Lisp_Object obj0, Lisp_Object obj1)
2100 Lisp_Object args[2];
2103 return Fvector(2, args);
2106 Lisp_Object vector3(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
2108 Lisp_Object args[3];
2112 return Fvector(3, args);
2115 #if 0 /* currently unused */
2118 vector4(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
2120 Lisp_Object args[4];
2125 return Fvector(4, args);
2129 vector5(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2130 Lisp_Object obj3, Lisp_Object obj4)
2132 Lisp_Object args[5];
2138 return Fvector(5, args);
2142 vector6(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2143 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
2145 Lisp_Object args[6];
2152 return Fvector(6, args);
2156 vector7(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2157 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5, Lisp_Object obj6)
2159 Lisp_Object args[7];
2167 return Fvector(7, args);
2171 vector8(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2172 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
2173 Lisp_Object obj6, Lisp_Object obj7)
2175 Lisp_Object args[8];
2184 return Fvector(8, args);
2188 /************************************************************************/
2189 /* Bit Vector allocation */
2190 /************************************************************************/
2192 static Lisp_Object all_bit_vectors;
2194 /* #### should allocate `small' bit vectors from a frob-block */
2195 static Lisp_Bit_Vector *make_bit_vector_internal(size_t sizei)
2197 size_t num_longs = BIT_VECTOR_LONG_STORAGE(sizei);
2199 FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Bit_Vector, unsigned long,
2201 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage(sizem);
2202 set_lheader_implementation(&p->lheader, &lrecord_bit_vector);
2204 INCREMENT_CONS_COUNTER(sizem, "bit-vector");
2206 bit_vector_length(p) = sizei;
2207 bit_vector_next(p) = all_bit_vectors;
2208 /* make sure the extra bits in the last long are 0; the calling
2209 functions might not set them. */
2210 p->bits[num_longs - 1] = 0;
2211 XSETBIT_VECTOR(all_bit_vectors, p);
2213 /* propagate seq implementation */
2214 p->lheader.morphisms = 0;
2218 Lisp_Object make_bit_vector(size_t length, Lisp_Object bit)
2220 Lisp_Bit_Vector *p = make_bit_vector_internal(length);
2221 size_t num_longs = BIT_VECTOR_LONG_STORAGE(length);
2226 memset(p->bits, 0, num_longs * sizeof(long));
2228 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
2229 memset(p->bits, ~0, num_longs * sizeof(long));
2230 /* But we have to make sure that the unused bits in the
2231 last long are 0, so that equal/hash is easy. */
2233 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
2237 Lisp_Object bit_vector;
2238 XSETBIT_VECTOR(bit_vector, p);
2244 make_bit_vector_from_byte_vector(unsigned char *bytevec, size_t length)
2247 Lisp_Bit_Vector *p = make_bit_vector_internal(length);
2249 for (i = 0; i < length; i++)
2250 set_bit_vector_bit(p, i, bytevec[i]);
2253 Lisp_Object bit_vector;
2254 XSETBIT_VECTOR(bit_vector, p);
2259 DEFUN("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
2260 Return a new bit vector of length LENGTH. with each bit set to BIT.
2261 BIT must be one of the integers 0 or 1. See also the function `bit-vector'.
2265 CONCHECK_NATNUM(length);
2267 return make_bit_vector(XINT(length), bit);
2270 DEFUN("bit-vector", Fbit_vector, 0, MANY, 0, /*
2271 Return a newly created bit vector with specified arguments as elements.
2272 Any number of arguments, even zero arguments, are allowed.
2273 Each argument must be one of the integers 0 or 1.
2275 (int nargs, Lisp_Object * args))
2278 Lisp_Bit_Vector *p = make_bit_vector_internal(nargs);
2280 for (i = 0; i < nargs; i++) {
2282 set_bit_vector_bit(p, i, !ZEROP(args[i]));
2286 Lisp_Object bit_vector;
2287 XSETBIT_VECTOR(bit_vector, p);
2292 /* the seq approach for conses */
2294 bvc_length(const seq_t bv)
2296 return bit_vector_length(XBIT_VECTOR((Lisp_Object)(long int)bv));
2300 bvc_iter_init(seq_t bv, seq_iter_t si)
2303 si->data = (void*)0;
2308 bvc_iter_next(seq_iter_t si, void **elt)
2310 if (si->seq != NULL &&
2311 (long int)si->data < bit_vector_length((Lisp_Bit_Vector*)si->seq)) {
2312 *elt = (void*)make_int(
2314 (Lisp_Bit_Vector*)si->seq, (size_t)si->data));
2315 si->data = (void*)((long int)si->data + 1L);
2323 bvc_iter_fini(seq_iter_t si)
2325 si->data = si->seq = NULL;
2330 bvc_iter_reset(seq_iter_t si)
2332 si->data = (void*)0;
2337 bvc_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
2339 size_t len = bit_vector_length((const Lisp_Bit_Vector*)s);
2340 volatile size_t i = 0;
2342 while (i < len && i < ntgt) {
2343 tgt[i] = (void*)make_int(
2344 bit_vector_bit((const Lisp_Bit_Vector*)s, i));
2350 static struct seq_impl_s __sbvc = {
2351 .length_f = bvc_length,
2352 .iter_init_f = bvc_iter_init,
2353 .iter_next_f = bvc_iter_next,
2354 .iter_fini_f = bvc_iter_fini,
2355 .iter_reset_f = bvc_iter_reset,
2356 .explode_f = bvc_explode,
2359 /************************************************************************/
2360 /* Compiled-function allocation */
2361 /************************************************************************/
2363 DECLARE_FIXED_TYPE_ALLOC(compiled_function, Lisp_Compiled_Function);
2364 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
2366 static Lisp_Object make_compiled_function(void)
2368 Lisp_Compiled_Function *f;
2371 ALLOCATE_FIXED_TYPE(compiled_function, Lisp_Compiled_Function, f);
2372 set_lheader_implementation(&f->lheader, &lrecord_compiled_function);
2375 f->specpdl_depth = 0;
2376 f->flags.documentationp = 0;
2377 f->flags.interactivep = 0;
2378 f->flags.domainp = 0; /* I18N3 */
2379 f->instructions = Qzero;
2380 f->constants = Qzero;
2382 f->doc_and_interactive = Qnil;
2383 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2384 f->annotated = Qnil;
2386 XSETCOMPILED_FUNCTION(fun, f);
2390 DEFUN("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
2391 Return a new compiled-function object.
2392 Usage: (arglist instructions constants stack-depth
2393 &optional doc-string interactive)
2394 Note that, unlike all other emacs-lisp functions, calling this with five
2395 arguments is NOT the same as calling it with six arguments, the last of
2396 which is nil. If the INTERACTIVE arg is specified as nil, then that means
2397 that this function was defined with `(interactive)'. If the arg is not
2398 specified, then that means the function is not interactive.
2399 This is terrible behavior which is retained for compatibility with old
2400 `.elc' files which expect these semantics.
2402 (int nargs, Lisp_Object * args))
2404 /* In a non-insane world this function would have this arglist...
2405 (arglist instructions constants stack_depth &optional doc_string interactive)
2407 Lisp_Object fun = make_compiled_function();
2408 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(fun);
2410 Lisp_Object arglist = args[0];
2411 Lisp_Object instructions = args[1];
2412 Lisp_Object constants = args[2];
2413 Lisp_Object stack_depth = args[3];
2414 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
2415 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
2417 if (nargs < 4 || nargs > 6)
2418 return Fsignal(Qwrong_number_of_arguments,
2419 list2(intern("make-byte-code"),
2422 /* Check for valid formal parameter list now, to allow us to use
2423 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
2425 EXTERNAL_LIST_LOOP_3(symbol, arglist, tail) {
2426 CHECK_SYMBOL(symbol);
2427 if (EQ(symbol, Qt) ||
2428 EQ(symbol, Qnil) || SYMBOL_IS_KEYWORD(symbol))
2429 signal_simple_error_2
2430 ("Invalid constant symbol in formal parameter list",
2434 f->arglist = arglist;
2436 /* `instructions' is a string or a cons (string . int) for a
2437 lazy-loaded function. */
2438 if (CONSP(instructions)) {
2439 CHECK_STRING(XCAR(instructions));
2440 CHECK_INT(XCDR(instructions));
2442 CHECK_STRING(instructions);
2444 f->instructions = instructions;
2446 if (!NILP(constants))
2447 CHECK_VECTOR(constants);
2448 f->constants = constants;
2450 CHECK_NATNUM(stack_depth);
2451 f->stack_depth = (unsigned short)XINT(stack_depth);
2453 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2454 if (!NILP(Vcurrent_compiled_function_annotation))
2455 f->annotated = Fcopy(Vcurrent_compiled_function_annotation);
2456 else if (!NILP(Vload_file_name_internal_the_purecopy))
2457 f->annotated = Vload_file_name_internal_the_purecopy;
2458 else if (!NILP(Vload_file_name_internal)) {
2459 struct gcpro gcpro1;
2460 GCPRO1(fun); /* don't let fun get reaped */
2461 Vload_file_name_internal_the_purecopy =
2462 Ffile_name_nondirectory(Vload_file_name_internal);
2463 f->annotated = Vload_file_name_internal_the_purecopy;
2466 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2468 /* doc_string may be nil, string, int, or a cons (string . int).
2469 interactive may be list or string (or unbound). */
2470 f->doc_and_interactive = Qunbound;
2472 if ((f->flags.domainp = !NILP(Vfile_domain)) != 0)
2473 f->doc_and_interactive = Vfile_domain;
2475 if ((f->flags.interactivep = !UNBOUNDP(interactive)) != 0) {
2476 f->doc_and_interactive
2477 = (UNBOUNDP(f->doc_and_interactive) ? interactive :
2478 Fcons(interactive, f->doc_and_interactive));
2480 if ((f->flags.documentationp = !NILP(doc_string)) != 0) {
2481 f->doc_and_interactive
2482 = (UNBOUNDP(f->doc_and_interactive) ? doc_string :
2483 Fcons(doc_string, f->doc_and_interactive));
2485 if (UNBOUNDP(f->doc_and_interactive))
2486 f->doc_and_interactive = Qnil;
2491 /************************************************************************/
2492 /* Symbol allocation */
2493 /************************************************************************/
2495 DECLARE_FIXED_TYPE_ALLOC(symbol, Lisp_Symbol);
2496 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
2498 DEFUN("make-symbol", Fmake_symbol, 1, 1, 0, /*
2499 Return a newly allocated uninterned symbol whose name is NAME.
2500 Its value and function definition are void, and its property list is nil.
2509 ALLOCATE_FIXED_TYPE(symbol, Lisp_Symbol, p);
2510 set_lheader_implementation(&p->lheader, &lrecord_symbol);
2511 p->name = XSTRING(name);
2513 p->value = Qunbound;
2514 p->function = Qunbound;
2520 /************************************************************************/
2521 /* Extent allocation */
2522 /************************************************************************/
2524 DECLARE_FIXED_TYPE_ALLOC(extent, struct extent);
2525 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
2527 struct extent *allocate_extent(void)
2531 ALLOCATE_FIXED_TYPE(extent, struct extent, e);
2532 set_lheader_implementation(&e->lheader, &lrecord_extent);
2533 extent_object(e) = Qnil;
2534 set_extent_start(e, -1);
2535 set_extent_end(e, -1);
2540 extent_face(e) = Qnil;
2541 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
2542 e->flags.detachable = 1;
2547 /************************************************************************/
2548 /* Event allocation */
2549 /************************************************************************/
2551 DECLARE_FIXED_TYPE_ALLOC(event, Lisp_Event);
2552 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
2554 Lisp_Object allocate_event(void)
2559 ALLOCATE_FIXED_TYPE(event, Lisp_Event, e);
2560 set_lheader_implementation(&e->lheader, &lrecord_event);
2566 /************************************************************************/
2567 /* Marker allocation */
2568 /************************************************************************/
2570 DECLARE_FIXED_TYPE_ALLOC(marker, Lisp_Marker);
2571 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
2573 DEFUN("make-marker", Fmake_marker, 0, 0, 0, /*
2574 Return a new marker which does not point at any place.
2581 ALLOCATE_FIXED_TYPE(marker, Lisp_Marker, p);
2582 set_lheader_implementation(&p->lheader, &lrecord_marker);
2587 p->insertion_type = 0;
2592 Lisp_Object noseeum_make_marker(void)
2597 NOSEEUM_ALLOCATE_FIXED_TYPE(marker, Lisp_Marker, p);
2598 set_lheader_implementation(&p->lheader, &lrecord_marker);
2603 p->insertion_type = 0;
2608 /************************************************************************/
2609 /* String allocation */
2610 /************************************************************************/
2612 /* The data for "short" strings generally resides inside of structs of type
2613 string_chars_block. The Lisp_String structure is allocated just like any
2614 other Lisp object (except for vectors), and these are freelisted when
2615 they get garbage collected. The data for short strings get compacted,
2616 but the data for large strings do not.
2618 Previously Lisp_String structures were relocated, but this caused a lot
2619 of bus-errors because the C code didn't include enough GCPRO's for
2620 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
2621 that the reference would get relocated).
2623 This new method makes things somewhat bigger, but it is MUCH safer. */
2625 DECLARE_FIXED_TYPE_ALLOC(string, Lisp_String);
2626 /* strings are used and freed quite often */
2627 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
2628 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
2630 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
2632 string_register_finaliser(Lisp_String *s)
2634 GC_finalization_proc *foo = NULL;
2636 auto void string_finaliser();
2638 auto void string_finaliser(void *obj, void *SXE_UNUSED(data))
2640 if (!(((Lisp_String*)obj)->lheader.c_readonly)) {
2641 yfree(((Lisp_String*)obj)->data);
2644 memset(obj, 0, sizeof(Lisp_String));
2648 SXE_DEBUG_GC("string-fina %p\n", s);
2649 GC_REGISTER_FINALIZER(s, string_finaliser, NULL, foo, bar);
2654 string_register_finaliser(Lisp_String *SXE_UNUSED(b))
2658 #endif /* HAVE_BDWGC */
2660 static Lisp_Object mark_string(Lisp_Object obj)
2662 Lisp_String *ptr = XSTRING(obj);
2664 if (CONSP(ptr->plist) && EXTENT_INFOP(XCAR(ptr->plist)))
2665 flush_cached_extent_info(XCAR(ptr->plist));
2666 #ifdef EF_USE_COMPRE
2667 mark_object(ptr->compre);
2672 static int string_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
2675 return (((len = XSTRING_LENGTH(obj1)) == XSTRING_LENGTH(obj2)) &&
2676 !memcmp(XSTRING_DATA(obj1), XSTRING_DATA(obj2), len));
2679 static const struct lrecord_description string_description[] = {
2680 {XD_BYTECOUNT, offsetof(Lisp_String, size)},
2681 {XD_OPAQUE_DATA_PTR, offsetof(Lisp_String, data), XD_INDIRECT(0, 1)},
2682 #ifdef EF_USE_COMPRE
2683 {XD_LISP_OBJECT, offsetof(Lisp_String, compre)},
2685 {XD_LISP_OBJECT, offsetof(Lisp_String, plist)},
2689 /* the seq implementation */
2691 str_length(const seq_t str)
2693 return string_char_length((const Lisp_String*)str);
2697 str_iter_init(seq_t str, seq_iter_t si)
2700 si->data = (void*)0;
2705 str_iter_next(seq_iter_t si, void **elt)
2707 if (si->seq != NULL &&
2708 (long int)si->data < string_char_length((Lisp_String*)si->seq)) {
2709 *elt = (void*)make_char(
2710 string_char((Lisp_String*)si->seq, (long int)si->data));
2711 si->data = (void*)((long int)si->data + 1);
2719 str_iter_fini(seq_iter_t si)
2721 si->data = si->seq = NULL;
2726 str_iter_reset(seq_iter_t si)
2728 si->data = (void*)0;
2733 str_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
2735 size_t len = string_char_length((const Lisp_String*)s);
2736 volatile size_t i = 0;
2738 while (i < len && i < ntgt) {
2739 tgt[i] = (void*)make_char(string_char((Lisp_String*)s, i));
2745 static struct seq_impl_s __sstr = {
2746 .length_f = str_length,
2747 .iter_init_f = str_iter_init,
2748 .iter_next_f = str_iter_next,
2749 .iter_fini_f = str_iter_fini,
2750 .iter_reset_f = str_iter_reset,
2751 .explode_f = str_explode,
2755 /* We store the string's extent info as the first element of the string's
2756 property list; and the string's MODIFF as the first or second element
2757 of the string's property list (depending on whether the extent info
2758 is present), but only if the string has been modified. This is ugly
2759 but it reduces the memory allocated for the string in the vast
2760 majority of cases, where the string is never modified and has no
2763 #### This means you can't use an int as a key in a string's plist. */
2765 static Lisp_Object *string_plist_ptr(Lisp_Object string)
2767 Lisp_Object *ptr = &XSTRING(string)->plist;
2769 if (CONSP(*ptr) && EXTENT_INFOP(XCAR(*ptr)))
2771 if (CONSP(*ptr) && INTP(XCAR(*ptr)))
2776 static Lisp_Object string_getprop(Lisp_Object string, Lisp_Object property)
2778 return external_plist_get(string_plist_ptr(string), property, 0,
2783 string_putprop(Lisp_Object string, Lisp_Object property, Lisp_Object value)
2785 external_plist_put(string_plist_ptr(string), property, value, 0,
2790 static int string_remprop(Lisp_Object string, Lisp_Object property)
2792 return external_remprop(string_plist_ptr(string), property, 0,
2796 static Lisp_Object string_plist(Lisp_Object string)
2798 return *string_plist_ptr(string);
2801 /* No `finalize', or `hash' methods.
2802 internal_hash() already knows how to hash strings and finalization
2803 is done with the ADDITIONAL_FREE_string macro, which is the
2804 standard way to do finalization when using
2805 SWEEP_FIXED_TYPE_BLOCK(). */
2806 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS("string", string,
2807 mark_string, print_string,
2813 string_plist, Lisp_String);
2815 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2816 /* String blocks contain this many useful bytes. */
2817 #define STRING_CHARS_BLOCK_SIZE \
2818 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
2819 ((2 * sizeof (struct string_chars_block *)) \
2820 + sizeof (EMACS_INT))))
2821 /* Block header for small strings. */
2822 struct string_chars_block {
2824 struct string_chars_block *next;
2825 struct string_chars_block *prev;
2826 /* Contents of string_chars_block->string_chars are interleaved
2827 string_chars structures (see below) and the actual string data */
2828 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
2831 static struct string_chars_block *first_string_chars_block;
2832 static struct string_chars_block *current_string_chars_block;
2834 /* If SIZE is the length of a string, this returns how many bytes
2835 * the string occupies in string_chars_block->string_chars
2836 * (including alignment padding).
2838 #define STRING_FULLSIZE(size) \
2839 ALIGN_SIZE(((size) + 1 + sizeof(Lisp_String*)), ALIGNOF(Lisp_String*))
2841 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
2842 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
2844 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL)
2845 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL))
2847 struct string_chars {
2848 Lisp_String *string;
2849 unsigned char chars[1];
2852 struct unused_string_chars {
2853 Lisp_String *string;
2857 static void init_string_chars_alloc(void)
2859 first_string_chars_block = ynew(struct string_chars_block);
2860 first_string_chars_block->prev = 0;
2861 first_string_chars_block->next = 0;
2862 first_string_chars_block->pos = 0;
2863 current_string_chars_block = first_string_chars_block;
2866 static struct string_chars*
2867 allocate_string_chars_struct(Lisp_String *string_it_goes_with,
2870 struct string_chars *s_chars;
2872 if (fullsize <= (countof(current_string_chars_block->string_chars)
2873 - current_string_chars_block->pos)) {
2874 /* This string can fit in the current string chars block */
2875 s_chars = (struct string_chars *)
2876 (current_string_chars_block->string_chars
2877 + current_string_chars_block->pos);
2878 current_string_chars_block->pos += fullsize;
2880 /* Make a new current string chars block */
2881 struct string_chars_block *new_scb =
2882 ynew(struct string_chars_block);
2884 current_string_chars_block->next = new_scb;
2885 new_scb->prev = current_string_chars_block;
2887 current_string_chars_block = new_scb;
2888 new_scb->pos = fullsize;
2889 s_chars = (struct string_chars *)
2890 current_string_chars_block->string_chars;
2893 s_chars->string = string_it_goes_with;
2895 INCREMENT_CONS_COUNTER(fullsize, "string chars");
2901 Lisp_Object make_uninit_string(Bytecount length)
2903 Lisp_String *s = NULL;
2904 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2905 EMACS_INT fullsize = STRING_FULLSIZE(length);
2909 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2910 assert(length >= 0 && fullsize > 0);
2913 /* Allocate the string header */
2914 ALLOCATE_FIXED_TYPE(string, Lisp_String, s);
2915 set_lheader_implementation(&s->lheader, &lrecord_string);
2916 string_register_finaliser(s);
2919 Bufbyte *foo = NULL;
2920 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
2921 foo = xnew_atomic_array(Bufbyte, length+1);
2922 assert(foo != NULL);
2924 if (BIG_STRING_FULLSIZE_P(fullsize)) {
2925 foo = xnew_atomic_array(Bufbyte, length + 1);
2926 assert(foo != NULL);
2928 foo = allocate_string_chars_struct(s, fullsize)->chars;
2929 assert(foo != NULL);
2932 set_string_data(s, foo);
2934 set_string_length(s, length);
2936 #ifdef EF_USE_COMPRE
2939 /* propagate the cat system, go with the standard impl of a seq first */
2940 s->lheader.morphisms = 0;
2942 set_string_byte(s, length, 0);
2948 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2949 static void verify_string_chars_integrity(void);
2952 /* Resize the string S so that DELTA bytes can be inserted starting
2953 at POS. If DELTA < 0, it means deletion starting at POS. If
2954 POS < 0, resize the string but don't copy any characters. Use
2955 this if you're planning on completely overwriting the string.
2958 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
2959 void resize_string(Lisp_String * s, Bytecount pos, Bytecount delta)
2964 /* trivial cases first */
2966 /* simplest case: no size change. */
2970 if (pos >= 0 && delta < 0) {
2971 /* If DELTA < 0, the functions below will delete the characters
2972 before POS. We want to delete characters *after* POS,
2973 however, so convert this to the appropriate form. */
2977 /* Both strings are big. We can just realloc().
2978 But careful! If the string is shrinking, we have to
2979 memmove() _before_ realloc(), and if growing, we have to
2980 memmove() _after_ realloc() - otherwise the access is
2981 illegal, and we might crash. */
2982 len = string_length(s) + 1 - pos;
2984 if (delta < 0 && pos >= 0) {
2985 memmove(string_data(s) + pos + delta,
2986 string_data(s) + pos, len);
2989 /* do the reallocation */
2990 foo = xrealloc(string_data(s), string_length(s) + delta + 1);
2991 set_string_data(s, foo);
2993 if (delta > 0 && pos >= 0) {
2994 memmove(string_data(s) + pos + delta,
2995 string_data(s) + pos, len);
2998 set_string_length(s, string_length(s) + delta);
2999 /* If pos < 0, the string won't be zero-terminated.
3000 Terminate now just to make sure. */
3001 string_data(s)[string_length(s)] = '\0';
3006 XSETSTRING(string, s);
3007 /* We also have to adjust all of the extent indices after the
3008 place we did the change. We say "pos - 1" because
3009 adjust_extents() is exclusive of the starting position
3011 adjust_extents(string, pos - 1, string_length(s), delta);
3015 #else /* !HAVE_BDWGC */
3016 void resize_string(Lisp_String * s, Bytecount pos, Bytecount delta)
3018 Bytecount oldfullsize, newfullsize;
3019 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3020 verify_string_chars_integrity();
3023 #ifdef ERROR_CHECK_BUFPOS
3025 assert(pos <= string_length(s));
3027 assert(pos + (-delta) <= string_length(s));
3030 assert((-delta) <= string_length(s));
3032 #endif /* ERROR_CHECK_BUFPOS */
3035 /* simplest case: no size change. */
3038 if (pos >= 0 && delta < 0)
3039 /* If DELTA < 0, the functions below will delete the characters
3040 before POS. We want to delete characters *after* POS, however,
3041 so convert this to the appropriate form. */
3044 oldfullsize = STRING_FULLSIZE(string_length(s));
3045 newfullsize = STRING_FULLSIZE(string_length(s) + delta);
3047 if (BIG_STRING_FULLSIZE_P(oldfullsize)) {
3048 if (BIG_STRING_FULLSIZE_P(newfullsize)) {
3049 /* Both strings are big. We can just realloc().
3050 But careful! If the string is shrinking, we have to
3051 memmove() _before_ realloc(), and if growing, we have to
3052 memmove() _after_ realloc() - otherwise the access is
3053 illegal, and we might crash. */
3054 Bytecount len = string_length(s) + 1 - pos;
3057 if (delta < 0 && pos >= 0)
3058 memmove(string_data(s) + pos + delta,
3059 string_data(s) + pos, len);
3061 foo = xrealloc(string_data(s),
3062 string_length(s) + delta + 1);
3063 set_string_data(s, foo);
3064 if (delta > 0 && pos >= 0) {
3065 memmove(string_data(s) + pos + delta,
3066 string_data(s) + pos, len);
3069 /* String has been demoted from BIG_STRING. */
3072 allocate_string_chars_struct(s, newfullsize)
3074 Bufbyte *old_data = string_data(s);
3077 memcpy(new_data, old_data, pos);
3078 memcpy(new_data + pos + delta, old_data + pos,
3079 string_length(s) + 1 - pos);
3081 set_string_data(s, new_data);
3084 } else { /* old string is small */
3086 if (oldfullsize == newfullsize) {
3087 /* special case; size change but the necessary
3088 allocation size won't change (up or down; code
3089 somewhere depends on there not being any unused
3090 allocation space, modulo any alignment
3093 Bufbyte *addroff = pos + string_data(s);
3095 memmove(addroff + delta, addroff,
3096 /* +1 due to zero-termination. */
3097 string_length(s) + 1 - pos);
3100 Bufbyte *old_data = string_data(s);
3101 Bufbyte *new_data = BIG_STRING_FULLSIZE_P(newfullsize)
3102 ? xnew_atomic_array(
3103 Bufbyte, string_length(s) + delta + 1)
3104 : allocate_string_chars_struct(
3105 s, newfullsize)->chars;
3108 memcpy(new_data, old_data, pos);
3109 memcpy(new_data + pos + delta, old_data + pos,
3110 string_length(s) + 1 - pos);
3112 set_string_data(s, new_data);
3115 /* We need to mark this chunk of the
3116 string_chars_block as unused so that
3117 compact_string_chars() doesn't freak. */
3118 struct string_chars *old_s_chars =
3119 (struct string_chars *)
3121 offsetof(struct string_chars, chars));
3122 /* Sanity check to make sure we aren't hosed by
3123 strange alignment/padding. */
3124 assert(old_s_chars->string == s);
3125 MARK_STRING_CHARS_AS_FREE(old_s_chars);
3126 ((struct unused_string_chars *)old_s_chars)->
3127 fullsize = oldfullsize;
3132 set_string_length(s, string_length(s) + delta);
3133 /* If pos < 0, the string won't be zero-terminated.
3134 Terminate now just to make sure. */
3135 string_data(s)[string_length(s)] = '\0';
3140 XSETSTRING(string, s);
3141 /* We also have to adjust all of the extent indices after the
3142 place we did the change. We say "pos - 1" because
3143 adjust_extents() is exclusive of the starting position
3145 adjust_extents(string, pos - 1, string_length(s), delta);
3147 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3148 verify_string_chars_integrity();
3154 void set_string_char(Lisp_String * s, Charcount i, Emchar c)
3156 Bufbyte newstr[MAX_EMCHAR_LEN];
3157 Bytecount bytoff = charcount_to_bytecount(string_data(s), i);
3158 Bytecount oldlen = charcount_to_bytecount(string_data(s) + bytoff, 1);
3159 Bytecount newlen = set_charptr_emchar(newstr, c);
3161 if (oldlen != newlen) {
3162 resize_string(s, bytoff, newlen - oldlen);
3164 /* Remember, string_data (s) might have changed so we can't cache it. */
3165 memcpy(string_data(s) + bytoff, newstr, newlen);
3170 DEFUN("make-string", Fmake_string, 2, 2, 0, /*
3171 Return a new string consisting of LENGTH copies of CHARACTER.
3172 LENGTH must be a non-negative integer.
3174 (length, character))
3176 CHECK_NATNUM(length);
3177 CHECK_CHAR_COERCE_INT(character);
3179 Bufbyte init_str[MAX_EMCHAR_LEN];
3180 int len = set_charptr_emchar(init_str, XCHAR(character));
3181 Lisp_Object val = make_uninit_string(len * XINT(length));
3184 /* Optimize the single-byte case */
3185 memset(XSTRING_DATA(val), XCHAR(character),
3186 XSTRING_LENGTH(val));
3189 Bufbyte *ptr = XSTRING_DATA(val);
3191 for (i = XINT(length); i; i--) {
3192 Bufbyte *init_ptr = init_str;
3195 *ptr++ = *init_ptr++;
3197 *ptr++ = *init_ptr++;
3199 *ptr++ = *init_ptr++;
3201 *ptr++ = *init_ptr++;
3211 DEFUN("string", Fstring, 0, MANY, 0, /*
3212 Concatenate all the argument characters and make the result a string.
3214 (int nargs, Lisp_Object * args))
3216 Bufbyte *storage, *p;
3218 int speccount = specpdl_depth();
3219 int len = nargs * MAX_EMCHAR_LEN;
3221 XMALLOC_OR_ALLOCA(storage, len, Bufbyte);
3223 for (; nargs; nargs--, args++) {
3224 Lisp_Object lisp_char = *args;
3225 CHECK_CHAR_COERCE_INT(lisp_char);
3226 p += set_charptr_emchar(p, XCHAR(lisp_char));
3228 result = make_string(storage, p - storage);
3229 XMALLOC_UNBIND(storage, len, speccount );
3234 /* Take some raw memory, which MUST already be in internal format,
3235 and package it up into a Lisp string. */
3237 make_string(const Bufbyte *contents, Bytecount length)
3241 /* Make sure we find out about bad make_string's when they happen */
3242 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
3243 /* Just for the assertions */
3244 bytecount_to_charcount(contents, length);
3247 val = make_uninit_string(length);
3248 memcpy(XSTRING_DATA(val), contents, length);
3252 /* Take some raw memory, encoded in some external data format,
3253 and convert it into a Lisp string. */
3255 make_ext_string(const Extbyte *contents, EMACS_INT length,
3256 Lisp_Object coding_system)
3259 TO_INTERNAL_FORMAT(DATA, (contents, length),
3260 LISP_STRING, string, coding_system);
3264 /* why arent the next 3 inlines? */
3265 Lisp_Object build_string(const char *str)
3267 /* Some strlen's crash and burn if passed null. */
3269 return make_string((const Bufbyte*)str, strlen(str));
3275 Lisp_Object build_ext_string(const char *str, Lisp_Object coding_system)
3277 /* Some strlen's crash and burn if passed null. */
3278 return make_ext_string((const Extbyte*)str, (str ? strlen(str) : 0), coding_system);
3281 Lisp_Object build_translated_string(const char *str)
3283 return build_string(GETTEXT(str));
3286 Lisp_Object make_string_nocopy(Bufbyte *contents, Bytecount length)
3291 /* Make sure we find out about bad make_string_nocopy's when they
3293 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
3294 /* Just for the assertions */
3295 bytecount_to_charcount(contents, length);
3298 /* Allocate the string header */
3299 ALLOCATE_FIXED_TYPE(string, Lisp_String, s);
3300 set_lheader_implementation(&s->lheader, &lrecord_string);
3301 SET_C_READONLY_RECORD_HEADER(&s->lheader);
3302 string_register_finaliser(s);
3305 #ifdef EF_USE_COMPRE
3308 set_string_data(s, (Bufbyte*)contents);
3309 set_string_length(s, length);
3315 /************************************************************************/
3316 /* lcrecord lists */
3317 /************************************************************************/
3319 /* Lcrecord lists are used to manage the allocation of particular
3320 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
3321 malloc() and garbage-collection junk) as much as possible.
3322 It is similar to the Blocktype class.
3326 1) Create an lcrecord-list object using make_lcrecord_list().
3327 This is often done at initialization. Remember to staticpro_nodump
3328 this object! The arguments to make_lcrecord_list() are the
3329 same as would be passed to alloc_lcrecord().
3330 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
3331 and pass the lcrecord-list earlier created.
3332 3) When done with the lcrecord, call free_managed_lcrecord().
3333 The standard freeing caveats apply: ** make sure there are no
3334 pointers to the object anywhere! **
3335 4) Calling free_managed_lcrecord() is just like kissing the
3336 lcrecord goodbye as if it were garbage-collected. This means:
3337 -- the contents of the freed lcrecord are undefined, and the
3338 contents of something produced by allocate_managed_lcrecord()
3339 are undefined, just like for alloc_lcrecord().
3340 -- the mark method for the lcrecord's type will *NEVER* be called
3342 -- the finalize method for the lcrecord's type will be called
3343 at the time that free_managed_lcrecord() is called.
3345 lcrecord lists do not work in bdwgc mode. -hrop
3349 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3351 mark_lcrecord_list(Lisp_Object obj)
3356 /* just imitate the lcrecord spectactular */
3358 make_lcrecord_list(size_t size,
3359 const struct lrecord_implementation *implementation)
3361 struct lcrecord_list *p =
3362 alloc_lcrecord_type(struct lcrecord_list,
3363 &lrecord_lcrecord_list);
3366 p->implementation = implementation;
3369 XSETLCRECORD_LIST(val, p);
3374 allocate_managed_lcrecord(Lisp_Object lcrecord_list)
3376 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3377 void *tmp = alloc_lcrecord(list->size, list->implementation);
3385 free_managed_lcrecord(Lisp_Object SXE_UNUSED(lcrecord_list), Lisp_Object lcrecord)
3387 struct free_lcrecord_header *free_header =
3388 (struct free_lcrecord_header*)XPNTR(lcrecord);
3389 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3390 const struct lrecord_implementation *imp =
3391 LHEADER_IMPLEMENTATION(lheader);
3393 if (imp->finalizer) {
3394 imp->finalizer(lheader, 0);
3402 mark_lcrecord_list(Lisp_Object obj)
3404 struct lcrecord_list *list = XLCRECORD_LIST(obj);
3405 Lisp_Object chain = list->free;
3407 while (!NILP(chain)) {
3408 struct lrecord_header *lheader = XRECORD_LHEADER(chain);
3409 struct free_lcrecord_header *free_header =
3410 (struct free_lcrecord_header *)lheader;
3413 /* There should be no other pointers to the free list. */
3414 !MARKED_RECORD_HEADER_P(lheader)
3416 /* Only lcrecords should be here. */
3417 !LHEADER_IMPLEMENTATION(lheader)->
3419 /* Only free lcrecords should be here. */
3420 free_header->lcheader.free &&
3421 /* The type of the lcrecord must be right. */
3422 LHEADER_IMPLEMENTATION(lheader) ==
3423 list->implementation &&
3424 /* So must the size. */
3425 (LHEADER_IMPLEMENTATION(lheader)->
3427 || LHEADER_IMPLEMENTATION(lheader)->
3428 static_size == list->size)
3431 MARK_RECORD_HEADER(lheader);
3432 chain = free_header->chain;
3439 make_lcrecord_list(size_t size,
3440 const struct lrecord_implementation *implementation)
3442 struct lcrecord_list *p =
3443 alloc_lcrecord_type(struct lcrecord_list,
3444 &lrecord_lcrecord_list);
3447 p->implementation = implementation;
3450 XSETLCRECORD_LIST(val, p);
3455 allocate_managed_lcrecord(Lisp_Object lcrecord_list)
3457 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3458 if (!NILP(list->free)) {
3459 Lisp_Object val = list->free;
3460 struct free_lcrecord_header *free_header =
3461 (struct free_lcrecord_header *)XPNTR(val);
3463 #ifdef ERROR_CHECK_GC
3464 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3466 /* There should be no other pointers to the free list. */
3467 assert(!MARKED_RECORD_HEADER_P(lheader));
3468 /* Only lcrecords should be here. */
3469 assert(!LHEADER_IMPLEMENTATION(lheader)->basic_p);
3470 /* Only free lcrecords should be here. */
3471 assert(free_header->lcheader.free);
3472 /* The type of the lcrecord must be right. */
3473 assert(LHEADER_IMPLEMENTATION(lheader) == list->implementation);
3474 /* So must the size. */
3475 assert(LHEADER_IMPLEMENTATION(lheader)->static_size == 0 ||
3476 LHEADER_IMPLEMENTATION(lheader)->static_size ==
3478 #endif /* ERROR_CHECK_GC */
3480 list->free = free_header->chain;
3481 free_header->lcheader.free = 0;
3484 void *tmp = alloc_lcrecord(list->size, list->implementation);
3493 free_managed_lcrecord(Lisp_Object lcrecord_list, Lisp_Object lcrecord)
3495 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3496 struct free_lcrecord_header *free_header =
3497 (struct free_lcrecord_header*)XPNTR(lcrecord);
3498 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3499 const struct lrecord_implementation *implementation
3500 = LHEADER_IMPLEMENTATION(lheader);
3502 /* Make sure the size is correct. This will catch, for example,
3503 putting a window configuration on the wrong free list. */
3504 gc_checking_assert((implementation->size_in_bytes_method ?
3505 implementation->size_in_bytes_method(lheader) :
3506 implementation->static_size)
3509 if (implementation->finalizer) {
3510 implementation->finalizer(lheader, 0);
3512 free_header->chain = list->free;
3513 free_header->lcheader.free = 1;
3514 list->free = lcrecord;
3518 DEFINE_LRECORD_IMPLEMENTATION("lcrecord-list", lcrecord_list,
3519 mark_lcrecord_list, internal_object_printer,
3520 0, 0, 0, 0, struct lcrecord_list);
3523 DEFUN("purecopy", Fpurecopy, 1, 1, 0, /*
3524 Kept for compatibility, returns its argument.
3526 Make a copy of OBJECT in pure storage.
3527 Recursively copies contents of vectors and cons cells.
3528 Does not copy symbols.
3535 /************************************************************************/
3536 /* Garbage Collection */
3537 /************************************************************************/
3539 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
3540 Additional ones may be defined by a module (none yet). We leave some
3541 room in `lrecord_implementations_table' for such new lisp object types. */
3542 const struct lrecord_implementation
3543 *lrecord_implementations_table[(unsigned int)lrecord_type_last_built_in_type
3544 + MODULE_DEFINABLE_TYPE_COUNT];
3545 unsigned int lrecord_type_count = (unsigned int)lrecord_type_last_built_in_type;
3546 /* Object marker functions are in the lrecord_implementation structure.
3547 But copying them to a parallel array is much more cache-friendly.
3548 This hack speeds up (garbage-collect) by about 5%. */
3549 Lisp_Object(*lrecord_markers[countof(lrecord_implementations_table)])
3552 #ifndef EF_USE_ASYNEQ
3553 struct gcpro *gcprolist;
3556 /* We want the staticpros relocated, but not the pointers found therein.
3557 Hence we use a trivial description, as for pointerless objects. */
3558 static const struct lrecord_description staticpro_description_1[] = {
3562 static const struct struct_description staticpro_description = {
3563 sizeof(Lisp_Object *),
3564 staticpro_description_1
3567 static const struct lrecord_description staticpros_description_1[] = {
3568 XD_DYNARR_DESC(Lisp_Object_ptr_dynarr, &staticpro_description),
3572 static const struct struct_description staticpros_description = {
3573 sizeof(Lisp_Object_ptr_dynarr),
3574 staticpros_description_1
3577 Lisp_Object_ptr_dynarr *staticpros;
3579 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
3580 garbage collection, and for dumping. */
3581 void staticpro(Lisp_Object * varaddress)
3584 Dynarr_add(staticpros, varaddress);
3585 dump_add_root_object(varaddress);
3589 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3590 Lisp_Object_ptr_dynarr *staticpros_nodump;
3592 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
3593 garbage collection, but not for dumping. */
3594 void staticpro_nodump(Lisp_Object * varaddress)
3597 Dynarr_add(staticpros_nodump, varaddress);
3603 #ifdef ERROR_CHECK_GC
3604 #define GC_CHECK_LHEADER_INVARIANTS(lheader) \
3606 struct lrecord_header * GCLI_lh = (lheader); \
3607 assert (GCLI_lh != 0); \
3608 assert (GCLI_lh->type < lrecord_type_count); \
3609 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
3610 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
3611 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
3614 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
3617 /* Mark reference to a Lisp_Object. If the object referred to has not been
3618 seen yet, recursively mark all the references contained in it. */
3620 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3621 void mark_object(Lisp_Object SXE_UNUSED(obj))
3627 void mark_object(Lisp_Object obj)
3629 if (obj == Qnull_pointer) {
3634 /* Checks we used to perform */
3635 /* if (EQ (obj, Qnull_pointer)) return; */
3636 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
3637 /* if (PURIFIED (XPNTR (obj))) return; */
3639 if (XTYPE(obj) == Lisp_Type_Record) {
3640 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
3642 GC_CHECK_LHEADER_INVARIANTS(lheader);
3644 gc_checking_assert(LHEADER_IMPLEMENTATION(lheader)->basic_p ||
3645 !((struct lcrecord_header *)lheader)->free);
3647 /* All c_readonly objects have their mark bit set,
3648 so that we only need to check the mark bit here. */
3649 if (!MARKED_RECORD_HEADER_P(lheader)) {
3650 MARK_RECORD_HEADER(lheader);
3652 if (RECORD_MARKER(lheader)) {
3653 obj = RECORD_MARKER(lheader) (obj);
3662 /* mark all of the conses in a list and mark the final cdr; but
3663 DO NOT mark the cars.
3665 Use only for internal lists! There should never be other pointers
3666 to the cons cells, because if so, the cars will remain unmarked
3667 even when they maybe should be marked. */
3668 void mark_conses_in_list(Lisp_Object obj)
3672 for (rest = obj; CONSP(rest); rest = XCDR(rest)) {
3673 if (CONS_MARKED_P(XCONS(rest)))
3675 MARK_CONS(XCONS(rest));
3681 /* Find all structures not marked, and free them. */
3683 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3684 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
3685 static int gc_count_bit_vector_storage;
3686 static int gc_count_num_short_string_in_use;
3687 static int gc_count_string_total_size;
3688 static int gc_count_short_string_total_size;
3691 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3693 /* stats on lcrecords in use - kinda kludgy */
3695 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3697 int instances_in_use;
3699 int instances_freed;
3701 int instances_on_free_list;
3702 } lcrecord_stats[countof(lrecord_implementations_table)
3703 + MODULE_DEFINABLE_TYPE_COUNT];
3706 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3707 static void tick_lcrecord_stats(const struct lrecord_header *h, int free_p)
3709 unsigned int type_index = h->type;
3711 if (((const struct lcrecord_header *)h)->free) {
3712 gc_checking_assert(!free_p);
3713 lcrecord_stats[type_index].instances_on_free_list++;
3715 const struct lrecord_implementation *implementation =
3716 LHEADER_IMPLEMENTATION(h);
3718 size_t sz = (implementation->size_in_bytes_method ?
3719 implementation->size_in_bytes_method(h) :
3720 implementation->static_size);
3722 lcrecord_stats[type_index].instances_freed++;
3723 lcrecord_stats[type_index].bytes_freed += sz;
3725 lcrecord_stats[type_index].instances_in_use++;
3726 lcrecord_stats[type_index].bytes_in_use += sz;
3732 /* Free all unmarked records */
3733 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3735 sweep_lcrecords_1(struct lcrecord_header *volatile*prev, int *used)
3738 /* int total_size = 0; */
3740 xzero(lcrecord_stats); /* Reset all statistics to 0. */
3742 /* First go through and call all the finalize methods.
3743 Then go through and free the objects. There used to
3744 be only one loop here, with the call to the finalizer
3745 occurring directly before the xfree() below. That
3746 is marginally faster but much less safe -- if the
3747 finalize method for an object needs to reference any
3748 other objects contained within it (and many do),
3749 we could easily be screwed by having already freed that
3752 for (struct lcrecord_header *volatile header = *prev;
3753 header; header = header->next) {
3754 struct lrecord_header *h = &(header->lheader);
3756 GC_CHECK_LHEADER_INVARIANTS(h);
3758 if (!MARKED_RECORD_HEADER_P(h) && !header->free) {
3759 if (LHEADER_IMPLEMENTATION(h)->finalizer)
3760 LHEADER_IMPLEMENTATION(h)->finalizer(h, 0);
3764 for (struct lcrecord_header *volatile header = *prev; header;) {
3765 struct lrecord_header *volatile h = &(header->lheader);
3766 if (MARKED_RECORD_HEADER_P(h)) {
3767 if (!C_READONLY_RECORD_HEADER_P(h))
3768 UNMARK_RECORD_HEADER(h);
3770 /* total_size += n->implementation->size_in_bytes (h); */
3771 /* #### May modify header->next on a C_READONLY lcrecord */
3772 prev = &(header->next);
3774 tick_lcrecord_stats(h, 0);
3776 struct lcrecord_header *next = header->next;
3778 tick_lcrecord_stats(h, 1);
3779 /* used to call finalizer right here. */
3785 /* *total = total_size; */
3790 sweep_bit_vectors_1(Lisp_Object * prev, int *used, int *total, int *storage)
3792 Lisp_Object bit_vector;
3795 int total_storage = 0;
3797 /* BIT_VECTORP fails because the objects are marked, which changes
3798 their implementation */
3799 for (bit_vector = *prev; !EQ(bit_vector, Qzero);) {
3800 Lisp_Bit_Vector *v = XBIT_VECTOR(bit_vector);
3802 if (MARKED_RECORD_P(bit_vector)) {
3803 if (!C_READONLY_RECORD_HEADER_P(&(v->lheader)))
3804 UNMARK_RECORD_HEADER(&(v->lheader));
3808 FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Bit_Vector,
3809 unsigned long, bits,
3810 BIT_VECTOR_LONG_STORAGE
3813 /* #### May modify next on a C_READONLY bitvector */
3814 prev = &(bit_vector_next(v));
3817 Lisp_Object next = bit_vector_next(v);
3824 *total = total_size;
3825 *storage = total_storage;
3829 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3830 to make macros prettier. */
3832 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3833 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type)
3835 #elif defined ERROR_CHECK_GC
3837 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3839 struct typename##_block *SFTB_current; \
3841 int num_free = 0, num_used = 0; \
3843 for (SFTB_current = current_##typename##_block, \
3844 SFTB_limit = current_##typename##_block_index; \
3849 for (SFTB_iii = 0; \
3850 SFTB_iii < SFTB_limit; \
3852 obj_type *SFTB_victim = \
3853 &(SFTB_current->block[SFTB_iii]); \
3855 if (LRECORD_FREE_P (SFTB_victim)) { \
3857 } else if (C_READONLY_RECORD_HEADER_P \
3858 (&SFTB_victim->lheader)) { \
3860 } else if (!MARKED_RECORD_HEADER_P \
3861 (&SFTB_victim->lheader)) { \
3863 FREE_FIXED_TYPE(typename, obj_type, \
3867 UNMARK_##typename(SFTB_victim); \
3870 SFTB_current = SFTB_current->prev; \
3871 SFTB_limit = countof(current_##typename##_block \
3875 gc_count_num_##typename##_in_use = num_used; \
3876 gc_count_num_##typename##_freelist = num_free; \
3879 #else /* !ERROR_CHECK_GC, !BDWGC*/
3881 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3883 struct typename##_block *SFTB_current; \
3884 struct typename##_block **SFTB_prev; \
3886 int num_free = 0, num_used = 0; \
3888 typename##_free_list = 0; \
3890 for (SFTB_prev = ¤t_##typename##_block, \
3891 SFTB_current = current_##typename##_block, \
3892 SFTB_limit = current_##typename##_block_index; \
3896 int SFTB_empty = 1; \
3897 Lisp_Free *SFTB_old_free_list = \
3898 typename##_free_list; \
3900 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; \
3902 obj_type *SFTB_victim = \
3903 &(SFTB_current->block[SFTB_iii]); \
3905 if (LRECORD_FREE_P (SFTB_victim)) { \
3907 PUT_FIXED_TYPE_ON_FREE_LIST \
3908 (typename, obj_type, \
3910 } else if (C_READONLY_RECORD_HEADER_P \
3911 (&SFTB_victim->lheader)) { \
3914 } else if (! MARKED_RECORD_HEADER_P \
3915 (&SFTB_victim->lheader)) { \
3917 FREE_FIXED_TYPE(typename, obj_type, \
3922 UNMARK_##typename (SFTB_victim); \
3925 if (!SFTB_empty) { \
3926 SFTB_prev = &(SFTB_current->prev); \
3927 SFTB_current = SFTB_current->prev; \
3928 } else if (SFTB_current == current_##typename##_block \
3929 && !SFTB_current->prev) { \
3930 /* No real point in freeing sole \
3931 * allocation block */ \
3934 struct typename##_block *SFTB_victim_block = \
3936 if (SFTB_victim_block == \
3937 current_##typename##_block) { \
3938 current_##typename##_block_index \
3940 (current_##typename##_block \
3943 SFTB_current = SFTB_current->prev; \
3945 *SFTB_prev = SFTB_current; \
3946 xfree(SFTB_victim_block); \
3947 /* Restore free list to what it was \
3948 before victim was swept */ \
3949 typename##_free_list = \
3950 SFTB_old_free_list; \
3951 num_free -= SFTB_limit; \
3954 SFTB_limit = countof (current_##typename##_block \
3958 gc_count_num_##typename##_in_use = num_used; \
3959 gc_count_num_##typename##_freelist = num_free; \
3962 #endif /* !ERROR_CHECK_GC */
3964 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3965 static void sweep_conses(void)
3967 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3968 #define ADDITIONAL_FREE_cons(ptr)
3970 SWEEP_FIXED_TYPE_BLOCK(cons, Lisp_Cons);
3974 /* Explicitly free a cons cell. */
3975 void free_cons(Lisp_Cons * ptr)
3977 #ifdef ERROR_CHECK_GC
3978 /* If the CAR is not an int, then it will be a pointer, which will
3979 always be four-byte aligned. If this cons cell has already been
3980 placed on the free list, however, its car will probably contain
3981 a chain pointer to the next cons on the list, which has cleverly
3982 had all its 0's and 1's inverted. This allows for a quick
3983 check to make sure we're not freeing something already freed. */
3984 if (POINTER_TYPE_P(XTYPE(ptr->car)))
3985 ASSERT_VALID_POINTER(XPNTR(ptr->car));
3986 #endif /* ERROR_CHECK_GC */
3988 #ifndef ALLOC_NO_POOLS
3989 FREE_FIXED_TYPE_WHEN_NOT_IN_GC(cons, Lisp_Cons, ptr);
3990 #endif /* ALLOC_NO_POOLS */
3993 /* explicitly free a list. You **must make sure** that you have
3994 created all the cons cells that make up this list and that there
3995 are no pointers to any of these cons cells anywhere else. If there
3996 are, you will lose. */
3998 void free_list(Lisp_Object list)
4000 Lisp_Object rest, next;
4002 for (rest = list; !NILP(rest); rest = next) {
4004 free_cons(XCONS(rest));
4008 /* explicitly free an alist. You **must make sure** that you have
4009 created all the cons cells that make up this alist and that there
4010 are no pointers to any of these cons cells anywhere else. If there
4011 are, you will lose. */
4013 void free_alist(Lisp_Object alist)
4015 Lisp_Object rest, next;
4017 for (rest = alist; !NILP(rest); rest = next) {
4019 free_cons(XCONS(XCAR(rest)));
4020 free_cons(XCONS(rest));
4024 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4025 static void sweep_compiled_functions(void)
4027 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4028 #define ADDITIONAL_FREE_compiled_function(ptr)
4030 SWEEP_FIXED_TYPE_BLOCK(compiled_function, Lisp_Compiled_Function);
4034 static void sweep_floats(void)
4036 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4037 #define ADDITIONAL_FREE_float(ptr)
4039 SWEEP_FIXED_TYPE_BLOCK(float, Lisp_Float);
4041 #endif /* HAVE_FPFLOAT */
4043 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
4047 #define UNMARK_bigz(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4048 #define ADDITIONAL_FREE_bigz(ptr) bigz_fini(ptr->data)
4050 SWEEP_FIXED_TYPE_BLOCK(bigz, Lisp_Bigz);
4052 #endif /* HAVE_MPZ */
4054 #if defined HAVE_MPQ && defined WITH_GMP
4058 #define UNMARK_bigq(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4059 #define ADDITIONAL_FREE_bigq(ptr) bigq_fini(ptr->data)
4061 SWEEP_FIXED_TYPE_BLOCK(bigq, Lisp_Bigq);
4063 #endif /* HAVE_MPQ */
4065 #if defined HAVE_MPF && defined WITH_GMP
4069 #define UNMARK_bigf(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4070 #define ADDITIONAL_FREE_bigf(ptr) bigf_fini(ptr->data)
4072 SWEEP_FIXED_TYPE_BLOCK(bigf, Lisp_Bigf);
4074 #endif /* HAVE_MPF */
4076 #if defined HAVE_MPFR && defined WITH_MPFR
4080 #define UNMARK_bigfr(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4081 #define ADDITIONAL_FREE_bigfr(ptr) bigfr_fini(ptr->data)
4083 SWEEP_FIXED_TYPE_BLOCK(bigfr, Lisp_Bigfr);
4085 #endif /* HAVE_MPFR */
4087 #if defined HAVE_PSEUG && defined WITH_PSEUG
4091 #define UNMARK_bigg(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4092 #define ADDITIONAL_FREE_bigg(ptr) bigg_fini(ptr->data)
4094 SWEEP_FIXED_TYPE_BLOCK(bigg, Lisp_Bigg);
4096 #endif /* HAVE_PSEUG */
4098 #if defined HAVE_MPC && defined WITH_MPC || \
4099 defined HAVE_PSEUC && defined WITH_PSEUC
4103 #define UNMARK_bigc(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4104 #define ADDITIONAL_FREE_bigc(ptr) bigc_fini(ptr->data)
4106 SWEEP_FIXED_TYPE_BLOCK(bigc, Lisp_Bigc);
4108 #endif /* HAVE_MPC */
4110 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
4112 sweep_quaterns (void)
4114 #define UNMARK_quatern(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4115 #define ADDITIONAL_FREE_quatern(ptr) quatern_fini(ptr->data)
4117 SWEEP_FIXED_TYPE_BLOCK(quatern, Lisp_Quatern);
4119 #endif /* HAVE_QUATERN */
4122 sweep_dynacats(void)
4124 #define UNMARK_dynacat(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4125 #define ADDITIONAL_FREE_dynacat(ptr) dynacat_fini(ptr);
4127 SWEEP_FIXED_TYPE_BLOCK(dynacat, struct dynacat_s);
4130 static void sweep_symbols(void)
4132 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4133 #define ADDITIONAL_FREE_symbol(ptr)
4135 SWEEP_FIXED_TYPE_BLOCK(symbol, Lisp_Symbol);
4138 static void sweep_extents(void)
4140 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4141 #define ADDITIONAL_FREE_extent(ptr)
4143 SWEEP_FIXED_TYPE_BLOCK(extent, struct extent);
4146 static void sweep_events(void)
4148 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4149 #define ADDITIONAL_FREE_event(ptr)
4151 SWEEP_FIXED_TYPE_BLOCK(event, Lisp_Event);
4154 static void sweep_markers(void)
4156 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4157 #define ADDITIONAL_FREE_marker(ptr) \
4158 do { Lisp_Object tem; \
4159 XSETMARKER (tem, ptr); \
4160 unchain_marker (tem); \
4163 SWEEP_FIXED_TYPE_BLOCK(marker, Lisp_Marker);
4167 /* Explicitly free a marker. */
4168 void free_marker(Lisp_Marker * ptr)
4170 /* Perhaps this will catch freeing an already-freed marker. */
4171 gc_checking_assert(ptr->lheader.type == lrecord_type_marker);
4173 #ifndef ALLOC_NO_POOLS
4174 FREE_FIXED_TYPE_WHEN_NOT_IN_GC(marker, Lisp_Marker, ptr);
4175 #endif /* ALLOC_NO_POOLS */
4178 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
4180 static void verify_string_chars_integrity(void)
4182 struct string_chars_block *sb;
4184 /* Scan each existing string block sequentially, string by string. */
4185 for (sb = first_string_chars_block; sb; sb = sb->next) {
4187 /* POS is the index of the next string in the block. */
4188 while (pos < sb->pos) {
4189 struct string_chars *s_chars =
4190 (struct string_chars *)&(sb->string_chars[pos]);
4191 Lisp_String *string;
4195 /* If the string_chars struct is marked as free (i.e. the
4196 STRING pointer is NULL) then this is an unused chunk of
4197 string storage. (See below.) */
4199 if (STRING_CHARS_FREE_P(s_chars)) {
4201 ((struct unused_string_chars *)s_chars)->
4207 string = s_chars->string;
4208 /* Must be 32-bit aligned. */
4209 assert((((int)string) & 3) == 0);
4211 size = string_length(string);
4212 fullsize = STRING_FULLSIZE(size);
4214 assert(!BIG_STRING_FULLSIZE_P(fullsize));
4215 assert(string_data(string) == s_chars->chars);
4218 assert(pos == sb->pos);
4222 #endif /* MULE && ERROR_CHECK_GC */
4224 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4225 /* Compactify string chars, relocating the reference to each --
4226 free any empty string_chars_block we see. */
4227 static void compact_string_chars(void)
4229 struct string_chars_block *to_sb = first_string_chars_block;
4231 struct string_chars_block *from_sb;
4233 /* Scan each existing string block sequentially, string by string. */
4234 for (from_sb = first_string_chars_block; from_sb;
4235 from_sb = from_sb->next) {
4237 /* FROM_POS is the index of the next string in the block. */
4238 while (from_pos < from_sb->pos) {
4239 struct string_chars *from_s_chars =
4240 (struct string_chars *)&(from_sb->
4241 string_chars[from_pos]);
4242 struct string_chars *to_s_chars;
4243 Lisp_String *string;
4247 /* If the string_chars struct is marked as free (i.e. the
4248 STRING pointer is NULL) then this is an unused chunk of
4249 string storage. This happens under Mule when a string's
4250 size changes in such a way that its fullsize changes.
4251 (Strings can change size because a different-length
4252 character can be substituted for another character.)
4253 In this case, after the bogus string pointer is the
4254 "fullsize" of this entry, i.e. how many bytes to skip. */
4256 if (STRING_CHARS_FREE_P(from_s_chars)) {
4258 ((struct unused_string_chars *)
4259 from_s_chars)->fullsize;
4260 from_pos += fullsize;
4264 string = from_s_chars->string;
4265 assert(!(LRECORD_FREE_P(string)));
4267 size = string_length(string);
4268 fullsize = STRING_FULLSIZE(size);
4270 gc_checking_assert(!BIG_STRING_FULLSIZE_P(fullsize));
4272 /* Just skip it if it isn't marked. */
4273 if (!MARKED_RECORD_HEADER_P(&(string->lheader))) {
4274 from_pos += fullsize;
4278 /* If it won't fit in what's left of TO_SB, close TO_SB
4279 out and go on to the next string_chars_block. We
4280 know that TO_SB cannot advance past FROM_SB here
4281 since FROM_SB is large enough to currently contain
4283 if ((to_pos + fullsize) >
4284 countof(to_sb->string_chars)) {
4285 to_sb->pos = to_pos;
4286 to_sb = to_sb->next;
4290 /* Compute new address of this string
4291 and update TO_POS for the space being used. */
4293 (struct string_chars *)&(to_sb->
4294 string_chars[to_pos]);
4296 /* Copy the string_chars to the new place. */
4297 if (from_s_chars != to_s_chars)
4298 memmove(to_s_chars, from_s_chars, fullsize);
4300 /* Relocate FROM_S_CHARS's reference */
4301 set_string_data(string, &(to_s_chars->chars[0]));
4303 from_pos += fullsize;
4308 /* Set current to the last string chars block still used and
4309 free any that follow. */
4310 for (volatile struct string_chars_block *victim = to_sb->next;
4312 volatile struct string_chars_block *tofree = victim;
4313 victim = victim->next;
4317 current_string_chars_block = to_sb;
4318 current_string_chars_block->pos = to_pos;
4319 current_string_chars_block->next = 0;
4322 static int debug_string_purity;
4324 static void debug_string_purity_print(Lisp_String * p)
4327 Charcount s = string_char_length(p);
4329 for (i = 0; i < s; i++) {
4330 Emchar ch = string_char(p, i);
4331 if (ch < 32 || ch >= 126)
4332 stderr_out("\\%03o", ch);
4333 else if (ch == '\\' || ch == '\"')
4334 stderr_out("\\%c", ch);
4336 stderr_out("%c", ch);
4342 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4343 static void sweep_strings(void)
4345 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
4346 int debug = debug_string_purity;
4348 #define UNMARK_string(ptr) \
4350 Lisp_String *p = (ptr); \
4351 size_t size = string_length (p); \
4352 UNMARK_RECORD_HEADER (&(p->lheader)); \
4353 num_bytes += size; \
4354 if (!BIG_STRING_SIZE_P (size)) { \
4355 num_small_bytes += size; \
4359 debug_string_purity_print (p); \
4361 #define ADDITIONAL_FREE_string(ptr) \
4363 size_t size = string_length (ptr); \
4364 if (BIG_STRING_SIZE_P(size)) { \
4369 SWEEP_FIXED_TYPE_BLOCK(string, Lisp_String);
4371 gc_count_num_short_string_in_use = num_small_used;
4372 gc_count_string_total_size = num_bytes;
4373 gc_count_short_string_total_size = num_small_bytes;
4377 /* I hate duplicating all this crap! */
4378 int marked_p(Lisp_Object obj)
4380 /* Checks we used to perform. */
4381 /* if (EQ (obj, Qnull_pointer)) return 1; */
4382 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
4383 /* if (PURIFIED (XPNTR (obj))) return 1; */
4385 if (XTYPE(obj) == Lisp_Type_Record) {
4386 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
4388 GC_CHECK_LHEADER_INVARIANTS(lheader);
4390 return MARKED_RECORD_HEADER_P(lheader);
4395 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4396 static void gc_sweep(void)
4398 /* Free all unmarked records. Do this at the very beginning,
4399 before anything else, so that the finalize methods can safely
4400 examine items in the objects. sweep_lcrecords_1() makes
4401 sure to call all the finalize methods *before* freeing anything,
4402 to complete the safety. */
4405 sweep_lcrecords_1(&all_lcrecords, &ignored);
4408 compact_string_chars();
4410 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
4411 macros) must be *extremely* careful to make sure they're not
4412 referencing freed objects. The only two existing finalize
4413 methods (for strings and markers) pass muster -- the string
4414 finalizer doesn't look at anything but its own specially-
4415 created block, and the marker finalizer only looks at live
4416 buffers (which will never be freed) and at the markers before
4417 and after it in the chain (which, by induction, will never be
4418 freed because if so, they would have already removed themselves
4421 /* Put all unmarked strings on free list, free'ing the string chars
4422 of large unmarked strings */
4425 /* Put all unmarked conses on free list */
4428 /* Free all unmarked bit vectors */
4429 sweep_bit_vectors_1(&all_bit_vectors,
4430 &gc_count_num_bit_vector_used,
4431 &gc_count_bit_vector_total_size,
4432 &gc_count_bit_vector_storage);
4434 /* Free all unmarked compiled-function objects */
4435 sweep_compiled_functions();
4438 /* Put all unmarked floats on free list */
4440 #endif /* HAVE_FPFLOAT */
4442 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
4443 /* Put all unmarked bignums on free list */
4445 #endif /* HAVE_MPZ */
4447 #if defined HAVE_MPQ && defined WITH_GMP
4448 /* Put all unmarked ratios on free list */
4450 #endif /* HAVE_MPQ */
4452 #if defined HAVE_MPF && defined WITH_GMP
4453 /* Put all unmarked bigfloats on free list */
4455 #endif /* HAVE_MPF */
4457 #if defined HAVE_MPFR && defined WITH_MPFR
4458 /* Put all unmarked bigfloats on free list */
4460 #endif /* HAVE_MPFR */
4462 #if defined HAVE_PSEUG && defined WITH_PSEUG
4463 /* Put all unmarked gaussian numbers on free list */
4465 #endif /* HAVE_PSEUG */
4467 #if defined HAVE_MPC && defined WITH_MPC || \
4468 defined HAVE_PSEUC && defined WITH_PSEUC
4469 /* Put all unmarked complex numbers on free list */
4471 #endif /* HAVE_MPC */
4473 #if defined HAVE_QUATERN && defined WITH_QUATERN
4474 /* Put all unmarked quaternions on free list */
4476 #endif /* HAVE_QUATERN */
4478 /* Put all unmarked dynacats on free list */
4481 /* Put all unmarked symbols on free list */
4484 /* Put all unmarked extents on free list */
4487 /* Put all unmarked markers on free list.
4488 Dechain each one first from the buffer into which it points. */
4494 pdump_objects_unmark();
4499 /* Clearing for disksave. */
4501 void disksave_object_finalization(void)
4503 /* It's important that certain information from the environment not get
4504 dumped with the executable (pathnames, environment variables, etc.).
4505 To make it easier to tell when this has happened with strings(1) we
4506 clear some known-to-be-garbage blocks of memory, so that leftover
4507 results of old evaluation don't look like potential problems.
4508 But first we set some notable variables to nil and do one more GC,
4509 to turn those strings into garbage.
4512 /* Yeah, this list is pretty ad-hoc... */
4513 Vprocess_environment = Qnil;
4514 /* Vexec_directory = Qnil; */
4515 Vdata_directory = Qnil;
4516 Vdoc_directory = Qnil;
4517 Vconfigure_info_directory = Qnil;
4520 /* Vdump_load_path = Qnil; */
4521 /* Release hash tables for locate_file */
4522 Flocate_file_clear_hashing(Qt);
4523 uncache_home_directory();
4525 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
4526 defined(LOADHIST_BUILTIN))
4527 Vload_history = Qnil;
4529 Vshell_file_name = Qnil;
4531 garbage_collect_1();
4533 /* Run the disksave finalization methods of all live objects. */
4534 disksave_object_finalization_1();
4536 /* Zero out the uninitialized (really, unused) part of the containers
4537 for the live strings. */
4538 /* dont know what its counterpart in bdwgc mode is, so leave it out */
4539 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4541 struct string_chars_block *scb;
4542 for (scb = first_string_chars_block; scb; scb = scb->next) {
4543 int count = sizeof(scb->string_chars) - scb->pos;
4545 assert(count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
4547 /* from the block's fill ptr to the end */
4548 memset((scb->string_chars + scb->pos), 0,
4555 /* There, that ought to be enough... */
4559 Lisp_Object restore_gc_inhibit(Lisp_Object val)
4561 gc_currently_forbidden = XINT(val);
4565 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
4566 static int gc_hooks_inhibited;
4568 struct post_gc_action {
4569 void (*fun) (void *);
4573 typedef struct post_gc_action post_gc_action;
4576 Dynarr_declare(post_gc_action);
4577 } post_gc_action_dynarr;
4579 static post_gc_action_dynarr *post_gc_actions;
4581 /* Register an action to be called at the end of GC.
4582 gc_in_progress is 0 when this is called.
4583 This is used when it is discovered that an action needs to be taken,
4584 but it's during GC, so it's not safe. (e.g. in a finalize method.)
4586 As a general rule, do not use Lisp objects here.
4587 And NEVER signal an error.
4590 void register_post_gc_action(void (*fun) (void *), void *arg)
4592 post_gc_action action;
4594 if (!post_gc_actions)
4595 post_gc_actions = Dynarr_new(post_gc_action);
4600 Dynarr_add(post_gc_actions, action);
4603 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4604 static void run_post_gc_actions(void)
4608 if (post_gc_actions) {
4609 for (i = 0; i < Dynarr_length(post_gc_actions); i++) {
4610 post_gc_action action = Dynarr_at(post_gc_actions, i);
4611 (action.fun) (action.arg);
4614 Dynarr_reset(post_gc_actions);
4620 mark_gcprolist(struct gcpro *gcpl)
4624 for (tail = gcpl; tail; tail = tail->next) {
4625 for (i = 0; i < tail->nvars; i++) {
4626 mark_object(tail->var[i]);
4632 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4641 void garbage_collect_1(void)
4643 SXE_DEBUG_GC("GC\n");
4644 #if defined GC_DEBUG_FLAG
4646 #endif /* GC_DEBUG_FLAG */
4648 GC_collect_a_little();
4652 GC_try_to_collect(stop_gc_p);
4658 void garbage_collect_1(void)
4660 #if MAX_SAVE_STACK > 0
4661 char stack_top_variable;
4662 extern char *stack_bottom;
4667 Lisp_Object pre_gc_cursor;
4668 struct gcpro gcpro1;
4671 || gc_currently_forbidden || in_display || preparing_for_armageddon)
4674 /* We used to call selected_frame() here.
4676 The following functions cannot be called inside GC
4677 so we move to after the above tests. */
4680 Lisp_Object device = Fselected_device(Qnil);
4681 /* Could happen during startup, eg. if always_gc */
4685 frame = DEVICE_SELECTED_FRAME(XDEVICE(device));
4687 signal_simple_error("No frames exist on device",
4693 pre_gc_cursor = Qnil;
4696 GCPRO1(pre_gc_cursor);
4698 /* Very important to prevent GC during any of the following
4699 stuff that might run Lisp code; otherwise, we'll likely
4700 have infinite GC recursion. */
4701 speccount = specpdl_depth();
4702 record_unwind_protect(restore_gc_inhibit,
4703 make_int(gc_currently_forbidden));
4704 gc_currently_forbidden = 1;
4706 if (!gc_hooks_inhibited)
4707 run_hook_trapping_errors("Error in pre-gc-hook", Qpre_gc_hook);
4709 /* Now show the GC cursor/message. */
4710 if (!noninteractive) {
4711 if (FRAME_WIN_P(f)) {
4712 Lisp_Object frame = make_frame(f);
4713 Lisp_Object cursor =
4714 glyph_image_instance(Vgc_pointer_glyph,
4715 FRAME_SELECTED_WINDOW(f),
4717 pre_gc_cursor = f->pointer;
4718 if (POINTER_IMAGE_INSTANCEP(cursor)
4719 /* don't change if we don't know how to change
4721 && POINTER_IMAGE_INSTANCEP(pre_gc_cursor)) {
4723 Fset_frame_pointer(frame, cursor);
4727 /* Don't print messages to the stream device. */
4728 if (STRINGP(Vgc_message) &&
4730 !FRAME_STREAM_P(f)) {
4731 char *msg = GETTEXT((char *) XSTRING_DATA(Vgc_message));
4732 Lisp_Object args[2], whole_msg;
4734 args[0] = build_string(
4735 msg ? msg : GETTEXT((char*)gc_default_message));
4736 args[1] = build_string("...");
4737 whole_msg = Fconcat(2, args);
4738 echo_area_message(f, (Bufbyte *) 0, whole_msg, 0, -1,
4739 Qgarbage_collecting);
4743 /***** Now we actually start the garbage collection. */
4747 inhibit_non_essential_printing_operations = 1;
4749 gc_generation_number[0]++;
4751 #if MAX_SAVE_STACK > 0
4753 /* Save a copy of the contents of the stack, for debugging. */
4755 /* Static buffer in which we save a copy of the C stack at each
4757 static char *stack_copy;
4758 static size_t stack_copy_size;
4760 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
4761 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
4762 if (stack_size < MAX_SAVE_STACK) {
4763 if (stack_copy_size < stack_size) {
4765 (char *)xrealloc(stack_copy, stack_size);
4766 stack_copy_size = stack_size;
4771 0 ? stack_bottom : &stack_top_variable,
4775 #endif /* MAX_SAVE_STACK > 0 */
4777 /* Do some totally ad-hoc resource clearing. */
4778 /* #### generalize this? */
4779 clear_event_resource();
4780 cleanup_specifiers();
4782 /* Mark all the special slots that serve as the roots of
4786 Lisp_Object **p = Dynarr_begin(staticpros);
4788 for (count = Dynarr_length(staticpros); count; count--) {
4793 { /* staticpro_nodump() */
4794 Lisp_Object **p = Dynarr_begin(staticpros_nodump);
4796 for (count = Dynarr_length(staticpros_nodump); count; count--) {
4801 #if defined(EF_USE_ASYNEQ)
4802 WITH_DLLIST_TRAVERSE(
4804 eq_worker_t eqw = dllist_item;
4805 struct gcpro *gcpl = eqw->gcprolist;
4806 mark_gcprolist(gcpl));
4809 mark_gcprolist(gcprolist);
4812 struct specbinding *bind;
4813 for (bind = specpdl; bind != specpdl_ptr; bind++) {
4814 mark_object(bind->symbol);
4815 mark_object(bind->old_value);
4820 struct catchtag *catch;
4821 for (catch = catchlist; catch; catch = catch->next) {
4822 mark_object(catch->tag);
4823 mark_object(catch->val);
4828 struct backtrace *backlist;
4829 for (backlist = backtrace_list; backlist;
4830 backlist = backlist->next) {
4831 int nargs = backlist->nargs;
4834 mark_object(*backlist->function);
4836 0 /* nargs == UNEVALLED || nargs == MANY */ )
4837 mark_object(backlist->args[0]);
4839 for (i = 0; i < nargs; i++)
4840 mark_object(backlist->args[i]);
4845 mark_profiling_info();
4847 /* OK, now do the after-mark stuff. This is for things that are only
4848 marked when something else is marked (e.g. weak hash tables). There
4849 may be complex dependencies between such objects -- e.g. a weak hash
4850 table might be unmarked, but after processing a later weak hash
4851 table, the former one might get marked. So we have to iterate until
4852 nothing more gets marked. */
4853 while (finish_marking_weak_hash_tables() > 0 ||
4854 finish_marking_weak_lists() > 0) ;
4856 /* And prune (this needs to be called after everything else has been
4857 marked and before we do any sweeping). */
4858 /* #### this is somewhat ad-hoc and should probably be an object
4860 prune_weak_hash_tables();
4863 prune_syntax_tables();
4867 consing_since_gc = 0;
4868 #ifndef DEBUG_SXEMACS
4869 /* Allow you to set it really fucking low if you really want ... */
4870 if (gc_cons_threshold < 10000)
4871 gc_cons_threshold = 10000;
4875 inhibit_non_essential_printing_operations = 0;
4878 run_post_gc_actions();
4880 /******* End of garbage collection ********/
4882 run_hook_trapping_errors("Error in post-gc-hook", Qpost_gc_hook);
4884 /* Now remove the GC cursor/message */
4885 if (!noninteractive) {
4887 Fset_frame_pointer(make_frame(f), pre_gc_cursor);
4888 else if (STRINGP(Vgc_message) && !FRAME_STREAM_P(f)) {
4889 char *msg = GETTEXT((char *)XSTRING_DATA(Vgc_message));
4891 /* Show "...done" only if the echo area would otherwise
4893 if (NILP(clear_echo_area(selected_frame(),
4894 Qgarbage_collecting, 0))) {
4895 Lisp_Object args[2], whole_msg;
4896 args[0] = build_string(
4898 : GETTEXT((char*)gc_default_message));
4899 args[1] = build_string("... done");
4900 whole_msg = Fconcat(2, args);
4901 echo_area_message(selected_frame(),
4902 (Bufbyte *) 0, whole_msg, 0,
4903 -1, Qgarbage_collecting);
4908 /* now stop inhibiting GC */
4909 unbind_to(speccount, Qnil);
4911 if (!breathing_space) {
4912 breathing_space = malloc(0xFFFF - MALLOC_OVERHEAD);
4921 /* Debugging aids. */
4922 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4923 #define HACK_O_MATIC(args...)
4924 #define gc_plist_hack(name, val, tail) \
4925 cons3(intern(name), Qzero, tail)
4929 static Lisp_Object gc_plist_hack(const char *name, int value, Lisp_Object tail)
4931 /* C doesn't have local functions (or closures, or GC, or readable
4932 syntax, or portable numeric datatypes, or bit-vectors, or characters,
4933 or arrays, or exceptions, or ...) */
4934 return cons3(intern(name), make_int(value), tail);
4937 #define HACK_O_MATIC(type, name, pl) \
4940 struct type##_block *x = current_##type##_block; \
4942 s += sizeof (*x) + MALLOC_OVERHEAD; \
4945 (pl) = gc_plist_hack ((name), s, (pl)); \
4949 DEFUN("garbage-collect", Fgarbage_collect, 0, 0, "", /*
4950 Reclaim storage for Lisp objects no longer needed.
4951 Return info on amount of space in use:
4952 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4953 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4955 where `PLIST' is a list of alternating keyword/value pairs providing
4956 more detailed information.
4957 Garbage collection happens automatically if you cons more than
4958 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4962 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4966 Lisp_Object pl = Qnil;
4968 int gc_count_vector_total_size = 0;
4970 garbage_collect_1();
4972 for (i = 0; i < lrecord_type_count; i++) {
4973 if (lcrecord_stats[i].bytes_in_use != 0
4974 || lcrecord_stats[i].bytes_freed != 0
4975 || lcrecord_stats[i].instances_on_free_list != 0) {
4978 lrecord_implementations_table[i]->name;
4979 int len = strlen(name);
4982 /* save this for the FSFmacs-compatible part of the
4984 if (i == lrecord_type_vector)
4985 gc_count_vector_total_size =
4986 lcrecord_stats[i].bytes_in_use +
4987 lcrecord_stats[i].bytes_freed;
4989 sz = snprintf(buf, sizeof(buf), "%s-storage", name);
4990 assert(sz >=0 && (size_t)sz < sizeof(buf));
4991 pl = gc_plist_hack(buf, lcrecord_stats[i].bytes_in_use,
4993 /* Okay, simple pluralization check for
4994 `symbol-value-varalias' */
4995 if (name[len - 1] == 's')
4996 sz = snprintf(buf, sizeof(buf), "%ses-freed", name);
4998 sz = snprintf(buf, sizeof(buf), "%ss-freed", name);
4999 assert(sz >=0 && (size_t)sz < sizeof(buf));
5000 if (lcrecord_stats[i].instances_freed != 0)
5001 pl = gc_plist_hack(buf,
5003 instances_freed, pl);
5004 if (name[len - 1] == 's')
5005 sz = snprintf(buf, sizeof(buf), "%ses-on-free-list", name);
5007 sz = snprintf(buf, sizeof(buf), "%ss-on-free-list", name);
5008 assert(sz >=0 && (size_t)sz < sizeof(buf));
5009 if (lcrecord_stats[i].instances_on_free_list != 0)
5010 pl = gc_plist_hack(buf,
5012 instances_on_free_list, pl);
5013 if (name[len - 1] == 's')
5014 sz = snprintf(buf, sizeof(buf), "%ses-used", name);
5016 sz = snprintf(buf, sizeof(buf), "%ss-used", name);
5017 assert(sz >=0 && (size_t)sz < sizeof(buf));
5018 pl = gc_plist_hack(buf,
5019 lcrecord_stats[i].instances_in_use,
5024 HACK_O_MATIC(extent, "extent-storage", pl);
5025 pl = gc_plist_hack("extents-free", gc_count_num_extent_freelist, pl);
5026 pl = gc_plist_hack("extents-used", gc_count_num_extent_in_use, pl);
5027 HACK_O_MATIC(event, "event-storage", pl);
5028 pl = gc_plist_hack("events-free", gc_count_num_event_freelist, pl);
5029 pl = gc_plist_hack("events-used", gc_count_num_event_in_use, pl);
5030 HACK_O_MATIC(marker, "marker-storage", pl);
5031 pl = gc_plist_hack("markers-free", gc_count_num_marker_freelist, pl);
5032 pl = gc_plist_hack("markers-used", gc_count_num_marker_in_use, pl);
5034 HACK_O_MATIC(float, "float-storage", pl);
5035 pl = gc_plist_hack("floats-free", gc_count_num_float_freelist, pl);
5036 pl = gc_plist_hack("floats-used", gc_count_num_float_in_use, pl);
5037 #endif /* HAVE_FPFLOAT */
5038 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
5039 HACK_O_MATIC(bigz, "bigz-storage", pl);
5040 pl = gc_plist_hack("bigzs-free", gc_count_num_bigz_freelist, pl);
5041 pl = gc_plist_hack("bigzs-used", gc_count_num_bigz_in_use, pl);
5042 #endif /* HAVE_MPZ */
5043 #if defined HAVE_MPQ && defined WITH_GMP
5044 HACK_O_MATIC(bigq, "bigq-storage", pl);
5045 pl = gc_plist_hack("bigqs-free", gc_count_num_bigq_freelist, pl);
5046 pl = gc_plist_hack("bigqs-used", gc_count_num_bigq_in_use, pl);
5047 #endif /* HAVE_MPQ */
5048 #if defined HAVE_MPF && defined WITH_GMP
5049 HACK_O_MATIC(bigf, "bigf-storage", pl);
5050 pl = gc_plist_hack("bigfs-free", gc_count_num_bigf_freelist, pl);
5051 pl = gc_plist_hack("bigfs-used", gc_count_num_bigf_in_use, pl);
5052 #endif /* HAVE_MPF */
5053 #if defined HAVE_MPFR && defined WITH_MPFR
5054 HACK_O_MATIC(bigfr, "bigfr-storage", pl);
5055 pl = gc_plist_hack("bigfrs-free", gc_count_num_bigfr_freelist, pl);
5056 pl = gc_plist_hack("bigfrs-used", gc_count_num_bigfr_in_use, pl);
5057 #endif /* HAVE_MPFR */
5058 #if defined HAVE_PSEUG && defined WITH_PSEUG
5059 HACK_O_MATIC(bigg, "bigg-storage", pl);
5060 pl = gc_plist_hack("biggs-free", gc_count_num_bigg_freelist, pl);
5061 pl = gc_plist_hack("biggs-used", gc_count_num_bigg_in_use, pl);
5062 #endif /* HAVE_PSEUG */
5063 #if defined HAVE_MPC && defined WITH_MPC || \
5064 defined HAVE_PSEUC && defined WITH_PSEUC
5065 HACK_O_MATIC(bigc, "bigc-storage", pl);
5066 pl = gc_plist_hack("bigcs-free", gc_count_num_bigc_freelist, pl);
5067 pl = gc_plist_hack("bigcs-used", gc_count_num_bigc_in_use, pl);
5068 #endif /* HAVE_MPC */
5069 #if defined HAVE_QUATERN && defined WITH_QUATERN
5070 HACK_O_MATIC(quatern, "quatern-storage", pl);
5071 pl = gc_plist_hack("quaterns-free", gc_count_num_quatern_freelist, pl);
5072 pl = gc_plist_hack("quaterns-used", gc_count_num_quatern_in_use, pl);
5073 #endif /* HAVE_QUATERN */
5075 HACK_O_MATIC(dynacat, "dynacat-storage", pl);
5076 pl = gc_plist_hack("dynacats-free", gc_count_num_dynacat_freelist, pl);
5077 pl = gc_plist_hack("dynacats-used", gc_count_num_dynacat_in_use, pl);
5079 HACK_O_MATIC(string, "string-header-storage", pl);
5080 pl = gc_plist_hack("long-strings-total-length",
5081 gc_count_string_total_size
5082 - gc_count_short_string_total_size, pl);
5083 HACK_O_MATIC(string_chars, "short-string-storage", pl);
5084 pl = gc_plist_hack("short-strings-total-length",
5085 gc_count_short_string_total_size, pl);
5086 pl = gc_plist_hack("strings-free", gc_count_num_string_freelist, pl);
5087 pl = gc_plist_hack("long-strings-used",
5088 gc_count_num_string_in_use
5089 - gc_count_num_short_string_in_use, pl);
5090 pl = gc_plist_hack("short-strings-used",
5091 gc_count_num_short_string_in_use, pl);
5093 HACK_O_MATIC(compiled_function, "compiled-function-storage", pl);
5094 pl = gc_plist_hack("compiled-functions-free",
5095 gc_count_num_compiled_function_freelist, pl);
5096 pl = gc_plist_hack("compiled-functions-used",
5097 gc_count_num_compiled_function_in_use, pl);
5099 pl = gc_plist_hack("bit-vector-storage", gc_count_bit_vector_storage,
5101 pl = gc_plist_hack("bit-vectors-total-length",
5102 gc_count_bit_vector_total_size, pl);
5103 pl = gc_plist_hack("bit-vectors-used", gc_count_num_bit_vector_used,
5106 HACK_O_MATIC(symbol, "symbol-storage", pl);
5107 pl = gc_plist_hack("symbols-free", gc_count_num_symbol_freelist, pl);
5108 pl = gc_plist_hack("symbols-used", gc_count_num_symbol_in_use, pl);
5110 HACK_O_MATIC(cons, "cons-storage", pl);
5111 pl = gc_plist_hack("conses-free", gc_count_num_cons_freelist, pl);
5112 pl = gc_plist_hack("conses-used", gc_count_num_cons_in_use, pl);
5114 /* The things we do for backwards-compatibility */
5115 /* fuck, what are we doing about those in the bdwgc era? -hrop */
5117 list6(Fcons(make_int(gc_count_num_cons_in_use),
5118 make_int(gc_count_num_cons_freelist)),
5119 Fcons(make_int(gc_count_num_symbol_in_use),
5120 make_int(gc_count_num_symbol_freelist)),
5121 Fcons(make_int(gc_count_num_marker_in_use),
5122 make_int(gc_count_num_marker_freelist)),
5123 make_int(gc_count_string_total_size),
5124 make_int(gc_count_vector_total_size), pl);
5130 /* grrrr ... lisp/itimer-autosave.el is using this, WTF? */
5131 DEFUN("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
5132 Return the number of bytes consed since the last garbage collection.
5133 \"Consed\" is a misnomer in that this actually counts allocation
5134 of all different kinds of objects, not just conses.
5136 If this value exceeds `gc-cons-threshold', a garbage collection happens.
5140 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
5143 return make_int(consing_since_gc);
5148 int object_dead_p(Lisp_Object obj)
5150 return ((BUFFERP(obj) && !BUFFER_LIVE_P(XBUFFER(obj))) ||
5151 (FRAMEP(obj) && !FRAME_LIVE_P(XFRAME(obj))) ||
5152 (WINDOWP(obj) && !WINDOW_LIVE_P(XWINDOW(obj))) ||
5153 (DEVICEP(obj) && !DEVICE_LIVE_P(XDEVICE(obj))) ||
5154 (CONSOLEP(obj) && !CONSOLE_LIVE_P(XCONSOLE(obj))) ||
5155 (EVENTP(obj) && !EVENT_LIVE_P(XEVENT(obj))) ||
5156 (EXTENTP(obj) && !EXTENT_LIVE_P(XEXTENT(obj))));
5159 #if defined MEMORY_USAGE_STATS && !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5161 /* Attempt to determine the actual amount of space that is used for
5162 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
5164 It seems that the following holds:
5166 1. When using the old allocator (malloc.c):
5168 -- blocks are always allocated in chunks of powers of two. For
5169 each block, there is an overhead of 8 bytes if rcheck is not
5170 defined, 20 bytes if it is defined. In other words, a
5171 one-byte allocation needs 8 bytes of overhead for a total of
5172 9 bytes, and needs to have 16 bytes of memory chunked out for
5175 2. When using the new allocator (gmalloc.c):
5177 -- blocks are always allocated in chunks of powers of two up
5178 to 4096 bytes. Larger blocks are allocated in chunks of
5179 an integral multiple of 4096 bytes. The minimum block
5180 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
5181 is defined. There is no per-block overhead, but there
5182 is an overhead of 3*sizeof (size_t) for each 4096 bytes
5185 3. When using the system malloc, anything goes, but they are
5186 generally slower and more space-efficient than the GNU
5187 allocators. One possibly reasonable assumption to make
5188 for want of better data is that sizeof (void *), or maybe
5189 2 * sizeof (void *), is required as overhead and that
5190 blocks are allocated in the minimum required size except
5191 that some minimum block size is imposed (e.g. 16 bytes). */
5194 malloced_storage_size(void *ptr, size_t claimed_size,
5195 struct overhead_stats * stats)
5197 size_t orig_claimed_size = claimed_size;
5201 if (claimed_size < 2 * sizeof(void *))
5202 claimed_size = 2 * sizeof(void *);
5203 # ifdef SUNOS_LOCALTIME_BUG
5204 if (claimed_size < 16)
5207 if (claimed_size < 4096) {
5210 /* compute the log base two, more or less, then use it to compute
5211 the block size needed. */
5213 /* It's big, it's heavy, it's wood! */
5214 while ((claimed_size /= 2) != 0)
5217 /* It's better than bad, it's good! */
5222 /* We have to come up with some average about the amount of
5224 if ((size_t) (rand() & 4095) < claimed_size)
5225 claimed_size += 3 * sizeof(void *);
5227 claimed_size += 4095;
5228 claimed_size &= ~4095;
5229 claimed_size += (claimed_size / 4096) * 3 * sizeof(size_t);
5232 #elif defined (SYSTEM_MALLOC)
5234 if (claimed_size < 16)
5236 claimed_size += 2 * sizeof(void *);
5238 #else /* old GNU allocator */
5240 # ifdef rcheck /* #### may not be defined here */
5248 /* compute the log base two, more or less, then use it to compute
5249 the block size needed. */
5251 /* It's big, it's heavy, it's wood! */
5252 while ((claimed_size /= 2) != 0)
5255 /* It's better than bad, it's good! */
5262 #endif /* old GNU allocator */
5265 stats->was_requested += orig_claimed_size;
5266 stats->malloc_overhead += claimed_size - orig_claimed_size;
5268 return claimed_size;
5271 size_t fixed_type_block_overhead(size_t size)
5273 size_t per_block = TYPE_ALLOC_SIZE(cons, unsigned char);
5274 size_t overhead = 0;
5275 size_t storage_size = malloced_storage_size(0, per_block, 0);
5276 while (size >= per_block) {
5278 overhead += sizeof(void *) + per_block - storage_size;
5280 if (rand() % per_block < size)
5281 overhead += sizeof(void *) + per_block - storage_size;
5285 #endif /* MEMORY_USAGE_STATS */
5287 #ifdef EF_USE_ASYNEQ
5289 init_main_worker(void)
5291 eq_worker_t res = eq_make_worker();
5292 eq_worker_thread(res) = pthread_self();
5297 #if defined HAVE_MPZ && defined WITH_GMP || \
5298 defined HAVE_MPFR && defined WITH_MPFR
5300 my_malloc(size_t bar)
5302 /* we use atomic here since GMP/MPFR do supervise their objects */
5303 void *foo = xmalloc(bar);
5304 SXE_DEBUG_GC_GMP("alloc :is %p :size %lu\n",
5305 foo, (long unsigned int)bar);
5309 /* We need the next two functions since GNU MP insists on giving us an extra
5312 my_realloc (void *ptr, size_t SXE_UNUSED(old_size), size_t new_size)
5314 void *foo = xrealloc(ptr, new_size);
5315 SXE_DEBUG_GC_GMP("gmp realloc :was %p :is %p\n", ptr, foo);
5320 my_free (void *ptr, size_t size)
5322 SXE_DEBUG_GC_GMP("free :was %p :size %lu\n",
5323 ptr, (long unsigned int)size);
5324 memset(ptr, 0, size);
5328 #endif /* GMP || MPFR */
5330 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && !defined GC_DEBUG_FLAG
5332 my_shy_warn_proc(char *msg, GC_word arg)
5334 /* just don't do anything */
5340 /* Initialization */
5341 void init_bdwgc(void);
5346 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
5347 # if defined GC_DEBUG_FLAG
5348 extern long GC_large_alloc_warn_interval;
5350 GC_time_limit = GC_TIME_UNLIMITED;
5351 GC_use_entire_heap = 0;
5354 GC_all_interior_pointers = 1;
5358 GC_free_space_divisor = 8;
5360 #if !defined GC_DEBUG_FLAG
5361 GC_set_warn_proc(my_shy_warn_proc);
5362 #else /* GC_DEBUG_FLAG */
5363 GC_large_alloc_warn_interval = 1L;
5364 #endif /* GC_DEBUG_FLAG */
5371 __init_gmp_mem_funs(void)
5373 #if defined HAVE_MPZ && defined WITH_GMP || \
5374 defined HAVE_MPFR && defined WITH_MPFR
5375 mp_set_memory_functions(my_malloc, my_realloc, my_free);
5376 #endif /* GMP || MPFR */
5379 void reinit_alloc_once_early(void)
5381 gc_generation_number[0] = 0;
5382 breathing_space = NULL;
5383 XSETINT(all_bit_vectors, 0); /* Qzero may not be set yet. */
5384 XSETINT(Vgc_message, 0);
5385 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5388 ignore_malloc_warnings = 1;
5389 #ifdef DOUG_LEA_MALLOC
5390 mallopt(M_TRIM_THRESHOLD, 128 * 1024); /* trim threshold */
5391 mallopt(M_MMAP_THRESHOLD, 64 * 1024); /* mmap threshold */
5392 #if 1 /* Moved to emacs.c */
5393 mallopt(M_MMAP_MAX, 0); /* max. number of mmap'ed areas */
5396 /* the category subsystem */
5397 morphisms[lrecord_type_cons].seq_impl = &__scons;
5398 morphisms[lrecord_type_vector].seq_impl = &__svec;
5399 morphisms[lrecord_type_string].seq_impl = &__sstr;
5400 morphisms[lrecord_type_bit_vector].seq_impl = &__sbvc;
5402 init_string_alloc();
5403 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5404 init_string_chars_alloc();
5407 init_symbol_alloc();
5408 init_compiled_function_alloc();
5412 __init_gmp_mem_funs();
5413 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP) && \
5414 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5417 #if defined HAVE_MPQ && defined WITH_GMP && \
5418 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5421 #if defined HAVE_MPF && defined WITH_GMP && \
5422 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5425 #if defined HAVE_MPFR && defined WITH_MPFR
5428 #if defined HAVE_PSEUG && defined HAVE_MPZ && defined WITH_PSEUG
5431 #if defined HAVE_MPC && defined WITH_MPC || \
5432 defined HAVE_PSEUC && defined WITH_PSEUC
5435 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
5436 init_quatern_alloc();
5438 init_dynacat_alloc();
5440 init_marker_alloc();
5441 init_extent_alloc();
5444 ignore_malloc_warnings = 0;
5446 /* we only use the 500k value for now */
5447 gc_cons_threshold = 500000;
5448 lrecord_uid_counter = 259;
5450 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5451 if (staticpros_nodump) {
5452 Dynarr_free(staticpros_nodump);
5454 staticpros_nodump = Dynarr_new2(Lisp_Object_ptr_dynarr, Lisp_Object *);
5455 /* merely a small optimization */
5456 Dynarr_resize(staticpros_nodump, 100);
5458 /* tuning the GCor */
5459 consing_since_gc = 0;
5460 debug_string_purity = 0;
5462 #ifdef EF_USE_ASYNEQ
5463 workers = make_noseeum_dllist();
5464 dllist_prepend(workers, init_main_worker());
5469 #if defined EF_USE_ASYNEQ && !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5470 SXE_MUTEX_INIT(&cons_mutex);
5473 gc_currently_forbidden = 0;
5474 gc_hooks_inhibited = 0;
5476 #ifdef ERROR_CHECK_TYPECHECK
5478 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5481 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5484 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5486 #endif /* ERROR_CHECK_TYPECHECK */
5489 void init_alloc_once_early(void)
5491 reinit_alloc_once_early();
5493 for (int i = 0; i < countof(lrecord_implementations_table); i++) {
5494 lrecord_implementations_table[i] = 0;
5497 INIT_LRECORD_IMPLEMENTATION(cons);
5498 INIT_LRECORD_IMPLEMENTATION(vector);
5499 INIT_LRECORD_IMPLEMENTATION(string);
5500 INIT_LRECORD_IMPLEMENTATION(lcrecord_list);
5502 staticpros = Dynarr_new2(Lisp_Object_ptr_dynarr, Lisp_Object *);
5503 Dynarr_resize(staticpros, 1410); /* merely a small optimization */
5504 dump_add_root_struct_ptr(&staticpros, &staticpros_description);
5506 /* GMP/MPFR mem funs */
5507 __init_gmp_mem_funs();
5512 void reinit_alloc(void)
5514 #ifdef EF_USE_ASYNEQ
5515 eq_worker_t main_th;
5516 assert(dllist_size(workers) == 1);
5517 main_th = dllist_car(workers);
5518 eq_worker_gcprolist(main_th) = NULL;
5524 void syms_of_alloc(void)
5526 DEFSYMBOL(Qpre_gc_hook);
5527 DEFSYMBOL(Qpost_gc_hook);
5528 DEFSYMBOL(Qgarbage_collecting);
5533 DEFSUBR(Fbit_vector);
5534 DEFSUBR(Fmake_byte_code);
5535 DEFSUBR(Fmake_list);
5536 DEFSUBR(Fmake_vector);
5537 DEFSUBR(Fmake_bit_vector);
5538 DEFSUBR(Fmake_string);
5540 DEFSUBR(Fmake_symbol);
5541 DEFSUBR(Fmake_marker);
5543 DEFSUBR(Fgarbage_collect);
5544 DEFSUBR(Fconsing_since_gc);
5547 void vars_of_alloc(void)
5549 DEFVAR_INT("gc-cons-threshold", &gc_cons_threshold /*
5550 *Number of bytes of consing between garbage collections.
5551 \"Consing\" is a misnomer in that this actually counts allocation
5552 of all different kinds of objects, not just conses.
5553 Garbage collection can happen automatically once this many bytes have been
5554 allocated since the last garbage collection. All data types count.
5556 Garbage collection happens automatically when `eval' or `funcall' are
5557 called. (Note that `funcall' is called implicitly as part of evaluation.)
5558 By binding this temporarily to a large number, you can effectively
5559 prevent garbage collection during a part of the program.
5561 See also `consing-since-gc'.
5564 #ifdef DEBUG_SXEMACS
5565 DEFVAR_INT("debug-allocation", &debug_allocation /*
5566 If non-zero, print out information to stderr about all objects allocated.
5567 See also `debug-allocation-backtrace-length'.
5569 debug_allocation = 0;
5571 DEFVAR_INT("debug-allocation-backtrace-length", &debug_allocation_backtrace_length /*
5572 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
5574 debug_allocation_backtrace_length = 2;
5577 DEFVAR_BOOL("purify-flag", &purify_flag /*
5578 Non-nil means loading Lisp code in order to dump an executable.
5579 This means that certain objects should be allocated in readonly space.
5582 DEFVAR_LISP("pre-gc-hook", &Vpre_gc_hook /*
5583 Function or functions to be run just before each garbage collection.
5584 Interrupts, garbage collection, and errors are inhibited while this hook
5585 runs, so be extremely careful in what you add here. In particular, avoid
5586 consing, and do not interact with the user.
5588 Vpre_gc_hook = Qnil;
5590 DEFVAR_LISP("post-gc-hook", &Vpost_gc_hook /*
5591 Function or functions to be run just after each garbage collection.
5592 Interrupts, garbage collection, and errors are inhibited while this hook
5593 runs, so be extremely careful in what you add here. In particular, avoid
5594 consing, and do not interact with the user.
5596 Vpost_gc_hook = Qnil;
5598 DEFVAR_LISP("gc-message", &Vgc_message /*
5599 String to print to indicate that a garbage collection is in progress.
5600 This is printed in the echo area. If the selected frame is on a
5601 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
5602 image instance) in the domain of the selected frame, the mouse pointer
5603 will change instead of this message being printed.
5604 If it has non-string value - nothing is printed.
5606 Vgc_message = build_string(gc_default_message);
5608 DEFVAR_LISP("gc-pointer-glyph", &Vgc_pointer_glyph /*
5609 Pointer glyph used to indicate that a garbage collection is in progress.
5610 If the selected window is on a window system and this glyph specifies a
5611 value (i.e. a pointer image instance) in the domain of the selected
5612 window, the pointer will be changed as specified during garbage collection.
5613 Otherwise, a message will be printed in the echo area, as controlled
5618 void complex_vars_of_alloc(void)
5620 Vgc_pointer_glyph = Fmake_glyph_internal(Qpointer);