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 #include <ent/ent-mpc.h>
1651 DECLARE_FIXED_TYPE_ALLOC(bigc, Lisp_Bigc);
1652 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigc 250
1654 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1656 bigc_register_finaliser(Lisp_Bigc *b)
1658 GC_finalization_proc *foo = NULL;
1660 auto void bigc_finaliser();
1662 auto void bigc_finaliser(void *obj, void *SXE_UNUSED(data))
1664 bigc_fini(bigc_data((Lisp_Bigc*)obj));
1666 memset(obj, 0, sizeof(Lisp_Bigc));
1670 GC_REGISTER_FINALIZER(b, bigc_finaliser, NULL, foo, bar);
1675 bigc_register_finaliser(Lisp_Bigc *SXE_UNUSED(b))
1679 #endif /* HAVE_BDWGC */
1681 /* This function creates a bigfloat with the default precision if the
1682 PRECISION argument is zero. */
1684 make_bigc(fpfloat re_value, fpfloat im_value, unsigned long precision)
1688 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1689 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1690 bigc_register_finaliser(c);
1692 if (precision == 0UL) {
1693 bigc_init(bigc_data(c));
1695 bigc_init_prec(bigc_data(c), precision);
1697 bigc_set_fpfloat_fpfloat(bigc_data(c), re_value, im_value);
1698 return wrap_bigc(c);
1701 /* This function creates a complex with the precision of its argument */
1703 make_bigc_bfr(bigfr re_value, bigfr im_value, unsigned long precision)
1707 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1708 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1709 bigc_register_finaliser(c);
1711 if (precision == 0UL) {
1712 bigc_init(bigc_data(c));
1714 bigc_init_prec(bigc_data(c), precision);
1716 bigc_set_bigfr_bigfr(bigc_data(c), re_value, im_value);
1717 return wrap_bigc(c);
1720 /* This function creates a complex with the precision of its argument */
1722 make_bigc_bc(bigc complex_value)
1726 ALLOCATE_FIXED_TYPE(bigc, Lisp_Bigc, c);
1727 set_lheader_implementation(&c->lheader, &lrecord_bigc);
1728 bigc_register_finaliser(c);
1730 bigc_init_prec(bigc_data(c), bigc_get_prec(complex_value));
1731 bigc_set(bigc_data(c), complex_value);
1732 return wrap_bigc(c);
1734 #endif /* HAVE_MPC */
1736 /*** Quaternions ***/
1737 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
1738 DECLARE_FIXED_TYPE_ALLOC(quatern, Lisp_Quatern);
1739 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_quatern 250
1741 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
1743 quatern_register_finaliser(Lisp_Quatern *b)
1745 GC_finalization_proc *foo = NULL;
1747 auto void quatern_finaliser();
1749 auto void quatern_finaliser(void *obj, void *SXE_UNUSED(data))
1751 quatern_fini(quatern_data((Lisp_Quatern*)obj));
1753 memset(obj, 0, sizeof(Lisp_Quatern));
1757 GC_REGISTER_FINALIZER(b, quatern_finaliser, NULL, foo, bar);
1762 quatern_register_finaliser(Lisp_Quatern *SXE_UNUSED(b))
1766 #endif /* HAVE_BDWGC */
1768 /* This function creates a quaternion. */
1770 make_quatern(EMACS_INT z, EMACS_INT i, EMACS_INT j, EMACS_INT k)
1774 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1775 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1776 quatern_register_finaliser(g);
1778 quatern_init(quatern_data(g));
1779 quatern_set_long_long_long_long(quatern_data(g), z, i, j, k);
1780 return wrap_quatern(g);
1784 make_quatern_bz(bigz z, bigz i, bigz j, bigz k)
1788 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1789 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1790 quatern_register_finaliser(g);
1792 quatern_init(quatern_data(g));
1793 quatern_set_bigz_bigz_bigz_bigz(quatern_data(g), z, i, j, k);
1794 return wrap_quatern(g);
1798 make_quatern_qu(quatern quaternion)
1802 ALLOCATE_FIXED_TYPE(quatern, Lisp_Quatern, g);
1803 set_lheader_implementation(&g->lheader, &lrecord_quatern);
1804 quatern_register_finaliser(g);
1806 quatern_init(quatern_data(g));
1807 quatern_set(quatern_data(g), quaternion);
1808 return wrap_quatern(g);
1810 #endif /* HAVE_QUATERN */
1813 make_indef_internal(indef sym)
1817 i = allocate_lisp_storage(sizeof(Lisp_Indef));
1818 set_lheader_implementation(&i->lheader, &lrecord_indef);
1819 indef_data(i) = sym;
1820 return wrap_indef(i);
1824 make_indef(indef sym)
1831 case COMPLEX_INFINITY:
1832 return Vcomplex_infinity;
1835 /* list some more here */
1836 case END_OF_COMPARABLE_INFINITIES:
1837 case END_OF_INFINITIES:
1839 return Vnot_a_number;
1843 #if defined HAVE_MPFR && defined WITH_MPFR
1845 make_indef_bfr(bigfr bfr_value)
1847 if (bigfr_nan_p(bfr_value)) {
1848 return make_indef(NOT_A_NUMBER);
1849 } else if (bigfr_inf_p(bfr_value)) {
1850 if (bigfr_sign(bfr_value) > 0)
1851 return make_indef(POS_INFINITY);
1853 return make_indef(NEG_INFINITY);
1855 return make_indef(NOT_A_NUMBER);
1860 DECLARE_FIXED_TYPE_ALLOC(dynacat, struct dynacat_s);
1861 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_dynacat 1000
1863 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
1865 dynacat_register_finaliser(dynacat_t b)
1867 GC_finalization_proc *foo = NULL;
1869 auto void dynacat_finaliser();
1871 auto void dynacat_finaliser(void *obj, void *SXE_UNUSED(data))
1873 SXE_DEBUG_GC("calling dynacat finaliser on %p\n", obj);
1876 memset(obj, 0, sizeof(struct dynacat_s));
1880 SXE_DEBUG_GC("dynacat-fina %p\n", b);
1881 GC_REGISTER_FINALIZER(b, dynacat_finaliser, NULL, foo, bar);
1886 dynacat_register_finaliser(dynacat_t SXE_UNUSED(b))
1890 #endif /* HAVE_BDWGC */
1893 make_dynacat(void *ptr)
1897 ALLOCATE_FIXED_TYPE(dynacat, struct dynacat_s, emp);
1898 dynacat_register_finaliser(emp);
1899 set_lheader_implementation(&emp->lheader, &lrecord_dynacat);
1902 emp->intprfun = NULL;
1909 return wrap_object(emp);
1913 /************************************************************************/
1914 /* Vector allocation */
1915 /************************************************************************/
1917 static Lisp_Object mark_vector(Lisp_Object obj)
1919 Lisp_Vector *ptr = XVECTOR(obj);
1920 int len = vector_length(ptr);
1923 for (i = 0; i < len - 1; i++)
1924 mark_object(ptr->contents[i]);
1925 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1928 static size_t size_vector(const void *lheader)
1930 return FLEXIBLE_ARRAY_STRUCT_SIZEOF(
1931 Lisp_Vector, Lisp_Object, contents,
1932 ((const Lisp_Vector*)lheader)->size);
1935 static int vector_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
1937 int len = XVECTOR_LENGTH(obj1);
1938 if (len != XVECTOR_LENGTH(obj2))
1942 Lisp_Object *ptr1 = XVECTOR_DATA(obj1);
1943 Lisp_Object *ptr2 = XVECTOR_DATA(obj2);
1945 if (!internal_equal(*ptr1++, *ptr2++, depth + 1))
1951 static hcode_t vector_hash(Lisp_Object obj, int depth)
1953 return HASH2(XVECTOR_LENGTH(obj),
1954 internal_array_hash(XVECTOR_DATA(obj),
1955 XVECTOR_LENGTH(obj), depth + 1));
1958 /* the seq approach for conses */
1960 vec_length(const seq_t v)
1962 return XVECTOR_LENGTH((Lisp_Object)(long int)v);
1966 vec_iter_init(seq_t v, seq_iter_t si)
1969 si->data = (void*)0;
1974 vec_iter_next(seq_iter_t si, void **elt)
1976 if (si->seq != NULL &&
1977 (long int)si->data < ((Lisp_Vector*)si->seq)->size) {
1978 *elt = (void*)vector_data((Lisp_Vector*)si->seq)
1979 [(long int)si->data];
1980 si->data = (void*)((long int)si->data + 1L);
1988 vec_iter_fini(seq_iter_t si)
1990 si->data = si->seq = NULL;
1995 vec_iter_reset(seq_iter_t si)
1997 si->data = (void*)0;
2002 vec_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
2004 size_t len = vector_length((const Lisp_Vector*)s);
2005 volatile size_t i = 0;
2007 while (i < len && i < ntgt) {
2008 tgt[i] = (void*)vector_data((const Lisp_Vector*)s)[i];
2014 static struct seq_impl_s __svec = {
2015 .length_f = vec_length,
2016 .iter_init_f = vec_iter_init,
2017 .iter_next_f = vec_iter_next,
2018 .iter_fini_f = vec_iter_fini,
2019 .iter_reset_f = vec_iter_reset,
2020 .explode_f = vec_explode,
2023 static const struct lrecord_description vector_description[] = {
2024 {XD_LONG, offsetof(Lisp_Vector, size)},
2025 {XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Vector, contents),
2030 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
2031 mark_vector, print_vector, 0,
2035 size_vector, Lisp_Vector);
2037 /* #### should allocate `small' vectors from a frob-block */
2038 static Lisp_Vector *make_vector_internal(size_t sizei)
2040 /* no vector_next */
2041 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Vector, Lisp_Object,
2043 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord(sizem, &lrecord_vector);
2046 p->header.lheader.morphisms = (1<<cat_mk_lc);
2050 Lisp_Object make_vector(size_t length, Lisp_Object object)
2052 Lisp_Vector *vecp = make_vector_internal(length);
2053 Lisp_Object *p = vector_data(vecp);
2060 XSETVECTOR(vector, vecp);
2065 DEFUN("make-vector", Fmake_vector, 2, 2, 0, /*
2066 Return a new vector of length LENGTH, with each element being OBJECT.
2067 See also the function `vector'.
2071 CONCHECK_NATNUM(length);
2072 return make_vector(XINT(length), object);
2075 DEFUN("vector", Fvector, 0, MANY, 0, /*
2076 Return a newly created vector with specified arguments as elements.
2077 Any number of arguments, even zero arguments, are allowed.
2079 (int nargs, Lisp_Object * args))
2081 Lisp_Vector *vecp = make_vector_internal(nargs);
2082 Lisp_Object *p = vector_data(vecp);
2089 XSETVECTOR(vector, vecp);
2094 Lisp_Object vector1(Lisp_Object obj0)
2096 return Fvector(1, &obj0);
2099 Lisp_Object vector2(Lisp_Object obj0, Lisp_Object obj1)
2101 Lisp_Object args[2];
2104 return Fvector(2, args);
2107 Lisp_Object vector3(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
2109 Lisp_Object args[3];
2113 return Fvector(3, args);
2116 #if 0 /* currently unused */
2119 vector4(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
2121 Lisp_Object args[4];
2126 return Fvector(4, args);
2130 vector5(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2131 Lisp_Object obj3, Lisp_Object obj4)
2133 Lisp_Object args[5];
2139 return Fvector(5, args);
2143 vector6(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2144 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
2146 Lisp_Object args[6];
2153 return Fvector(6, args);
2157 vector7(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2158 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5, Lisp_Object obj6)
2160 Lisp_Object args[7];
2168 return Fvector(7, args);
2172 vector8(Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
2173 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
2174 Lisp_Object obj6, Lisp_Object obj7)
2176 Lisp_Object args[8];
2185 return Fvector(8, args);
2189 /************************************************************************/
2190 /* Bit Vector allocation */
2191 /************************************************************************/
2193 static Lisp_Object all_bit_vectors;
2195 /* #### should allocate `small' bit vectors from a frob-block */
2196 static Lisp_Bit_Vector *make_bit_vector_internal(size_t sizei)
2198 size_t num_longs = BIT_VECTOR_LONG_STORAGE(sizei);
2200 FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Bit_Vector, unsigned long,
2202 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage(sizem);
2203 set_lheader_implementation(&p->lheader, &lrecord_bit_vector);
2205 INCREMENT_CONS_COUNTER(sizem, "bit-vector");
2207 bit_vector_length(p) = sizei;
2208 bit_vector_next(p) = all_bit_vectors;
2209 /* make sure the extra bits in the last long are 0; the calling
2210 functions might not set them. */
2211 p->bits[num_longs - 1] = 0;
2212 XSETBIT_VECTOR(all_bit_vectors, p);
2214 /* propagate seq implementation */
2215 p->lheader.morphisms = 0;
2219 Lisp_Object make_bit_vector(size_t length, Lisp_Object bit)
2221 Lisp_Bit_Vector *p = make_bit_vector_internal(length);
2222 size_t num_longs = BIT_VECTOR_LONG_STORAGE(length);
2227 memset(p->bits, 0, num_longs * sizeof(long));
2229 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
2230 memset(p->bits, ~0, num_longs * sizeof(long));
2231 /* But we have to make sure that the unused bits in the
2232 last long are 0, so that equal/hash is easy. */
2234 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
2238 Lisp_Object bit_vector;
2239 XSETBIT_VECTOR(bit_vector, p);
2245 make_bit_vector_from_byte_vector(unsigned char *bytevec, size_t length)
2248 Lisp_Bit_Vector *p = make_bit_vector_internal(length);
2250 for (i = 0; i < length; i++)
2251 set_bit_vector_bit(p, i, bytevec[i]);
2254 Lisp_Object bit_vector;
2255 XSETBIT_VECTOR(bit_vector, p);
2260 DEFUN("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
2261 Return a new bit vector of length LENGTH. with each bit set to BIT.
2262 BIT must be one of the integers 0 or 1. See also the function `bit-vector'.
2266 CONCHECK_NATNUM(length);
2268 return make_bit_vector(XINT(length), bit);
2271 DEFUN("bit-vector", Fbit_vector, 0, MANY, 0, /*
2272 Return a newly created bit vector with specified arguments as elements.
2273 Any number of arguments, even zero arguments, are allowed.
2274 Each argument must be one of the integers 0 or 1.
2276 (int nargs, Lisp_Object * args))
2279 Lisp_Bit_Vector *p = make_bit_vector_internal(nargs);
2281 for (i = 0; i < nargs; i++) {
2283 set_bit_vector_bit(p, i, !ZEROP(args[i]));
2287 Lisp_Object bit_vector;
2288 XSETBIT_VECTOR(bit_vector, p);
2293 /* the seq approach for conses */
2295 bvc_length(const seq_t bv)
2297 return bit_vector_length(XBIT_VECTOR((Lisp_Object)(long int)bv));
2301 bvc_iter_init(seq_t bv, seq_iter_t si)
2304 si->data = (void*)0;
2309 bvc_iter_next(seq_iter_t si, void **elt)
2311 if (si->seq != NULL &&
2312 (long int)si->data < bit_vector_length((Lisp_Bit_Vector*)si->seq)) {
2313 *elt = (void*)make_int(
2315 (Lisp_Bit_Vector*)si->seq, (size_t)si->data));
2316 si->data = (void*)((long int)si->data + 1L);
2324 bvc_iter_fini(seq_iter_t si)
2326 si->data = si->seq = NULL;
2331 bvc_iter_reset(seq_iter_t si)
2333 si->data = (void*)0;
2338 bvc_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
2340 size_t len = bit_vector_length((const Lisp_Bit_Vector*)s);
2341 volatile size_t i = 0;
2343 while (i < len && i < ntgt) {
2344 tgt[i] = (void*)make_int(
2345 bit_vector_bit((const Lisp_Bit_Vector*)s, i));
2351 static struct seq_impl_s __sbvc = {
2352 .length_f = bvc_length,
2353 .iter_init_f = bvc_iter_init,
2354 .iter_next_f = bvc_iter_next,
2355 .iter_fini_f = bvc_iter_fini,
2356 .iter_reset_f = bvc_iter_reset,
2357 .explode_f = bvc_explode,
2360 /************************************************************************/
2361 /* Compiled-function allocation */
2362 /************************************************************************/
2364 DECLARE_FIXED_TYPE_ALLOC(compiled_function, Lisp_Compiled_Function);
2365 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
2367 static Lisp_Object make_compiled_function(void)
2369 Lisp_Compiled_Function *f;
2372 ALLOCATE_FIXED_TYPE(compiled_function, Lisp_Compiled_Function, f);
2373 set_lheader_implementation(&f->lheader, &lrecord_compiled_function);
2376 f->specpdl_depth = 0;
2377 f->flags.documentationp = 0;
2378 f->flags.interactivep = 0;
2379 f->flags.domainp = 0; /* I18N3 */
2380 f->instructions = Qzero;
2381 f->constants = Qzero;
2383 f->doc_and_interactive = Qnil;
2384 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2385 f->annotated = Qnil;
2387 XSETCOMPILED_FUNCTION(fun, f);
2391 DEFUN("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
2392 Return a new compiled-function object.
2393 Usage: (arglist instructions constants stack-depth
2394 &optional doc-string interactive)
2395 Note that, unlike all other emacs-lisp functions, calling this with five
2396 arguments is NOT the same as calling it with six arguments, the last of
2397 which is nil. If the INTERACTIVE arg is specified as nil, then that means
2398 that this function was defined with `(interactive)'. If the arg is not
2399 specified, then that means the function is not interactive.
2400 This is terrible behavior which is retained for compatibility with old
2401 `.elc' files which expect these semantics.
2403 (int nargs, Lisp_Object * args))
2405 /* In a non-insane world this function would have this arglist...
2406 (arglist instructions constants stack_depth &optional doc_string interactive)
2408 Lisp_Object fun = make_compiled_function();
2409 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(fun);
2411 Lisp_Object arglist = args[0];
2412 Lisp_Object instructions = args[1];
2413 Lisp_Object constants = args[2];
2414 Lisp_Object stack_depth = args[3];
2415 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
2416 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
2418 if (nargs < 4 || nargs > 6)
2419 return Fsignal(Qwrong_number_of_arguments,
2420 list2(intern("make-byte-code"),
2423 /* Check for valid formal parameter list now, to allow us to use
2424 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
2426 EXTERNAL_LIST_LOOP_3(symbol, arglist, tail) {
2427 CHECK_SYMBOL(symbol);
2428 if (EQ(symbol, Qt) ||
2429 EQ(symbol, Qnil) || SYMBOL_IS_KEYWORD(symbol))
2430 signal_simple_error_2
2431 ("Invalid constant symbol in formal parameter list",
2435 f->arglist = arglist;
2437 /* `instructions' is a string or a cons (string . int) for a
2438 lazy-loaded function. */
2439 if (CONSP(instructions)) {
2440 CHECK_STRING(XCAR(instructions));
2441 CHECK_INT(XCDR(instructions));
2443 CHECK_STRING(instructions);
2445 f->instructions = instructions;
2447 if (!NILP(constants))
2448 CHECK_VECTOR(constants);
2449 f->constants = constants;
2451 CHECK_NATNUM(stack_depth);
2452 f->stack_depth = (unsigned short)XINT(stack_depth);
2454 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2455 if (!NILP(Vcurrent_compiled_function_annotation))
2456 f->annotated = Fcopy(Vcurrent_compiled_function_annotation);
2457 else if (!NILP(Vload_file_name_internal_the_purecopy))
2458 f->annotated = Vload_file_name_internal_the_purecopy;
2459 else if (!NILP(Vload_file_name_internal)) {
2460 struct gcpro gcpro1;
2461 GCPRO1(fun); /* don't let fun get reaped */
2462 Vload_file_name_internal_the_purecopy =
2463 Ffile_name_nondirectory(Vload_file_name_internal);
2464 f->annotated = Vload_file_name_internal_the_purecopy;
2467 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
2469 /* doc_string may be nil, string, int, or a cons (string . int).
2470 interactive may be list or string (or unbound). */
2471 f->doc_and_interactive = Qunbound;
2473 if ((f->flags.domainp = !NILP(Vfile_domain)) != 0)
2474 f->doc_and_interactive = Vfile_domain;
2476 if ((f->flags.interactivep = !UNBOUNDP(interactive)) != 0) {
2477 f->doc_and_interactive
2478 = (UNBOUNDP(f->doc_and_interactive) ? interactive :
2479 Fcons(interactive, f->doc_and_interactive));
2481 if ((f->flags.documentationp = !NILP(doc_string)) != 0) {
2482 f->doc_and_interactive
2483 = (UNBOUNDP(f->doc_and_interactive) ? doc_string :
2484 Fcons(doc_string, f->doc_and_interactive));
2486 if (UNBOUNDP(f->doc_and_interactive))
2487 f->doc_and_interactive = Qnil;
2492 /************************************************************************/
2493 /* Symbol allocation */
2494 /************************************************************************/
2496 DECLARE_FIXED_TYPE_ALLOC(symbol, Lisp_Symbol);
2497 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
2499 DEFUN("make-symbol", Fmake_symbol, 1, 1, 0, /*
2500 Return a newly allocated uninterned symbol whose name is NAME.
2501 Its value and function definition are void, and its property list is nil.
2510 ALLOCATE_FIXED_TYPE(symbol, Lisp_Symbol, p);
2511 set_lheader_implementation(&p->lheader, &lrecord_symbol);
2512 p->name = XSTRING(name);
2514 p->value = Qunbound;
2515 p->function = Qunbound;
2521 /************************************************************************/
2522 /* Extent allocation */
2523 /************************************************************************/
2525 DECLARE_FIXED_TYPE_ALLOC(extent, struct extent);
2526 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
2528 struct extent *allocate_extent(void)
2532 ALLOCATE_FIXED_TYPE(extent, struct extent, e);
2533 set_lheader_implementation(&e->lheader, &lrecord_extent);
2534 extent_object(e) = Qnil;
2535 set_extent_start(e, -1);
2536 set_extent_end(e, -1);
2541 extent_face(e) = Qnil;
2542 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
2543 e->flags.detachable = 1;
2548 /************************************************************************/
2549 /* Event allocation */
2550 /************************************************************************/
2552 DECLARE_FIXED_TYPE_ALLOC(event, Lisp_Event);
2553 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
2555 Lisp_Object allocate_event(void)
2560 ALLOCATE_FIXED_TYPE(event, Lisp_Event, e);
2561 set_lheader_implementation(&e->lheader, &lrecord_event);
2567 /************************************************************************/
2568 /* Marker allocation */
2569 /************************************************************************/
2571 DECLARE_FIXED_TYPE_ALLOC(marker, Lisp_Marker);
2572 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
2574 DEFUN("make-marker", Fmake_marker, 0, 0, 0, /*
2575 Return a new marker which does not point at any place.
2582 ALLOCATE_FIXED_TYPE(marker, Lisp_Marker, p);
2583 set_lheader_implementation(&p->lheader, &lrecord_marker);
2588 p->insertion_type = 0;
2593 Lisp_Object noseeum_make_marker(void)
2598 NOSEEUM_ALLOCATE_FIXED_TYPE(marker, Lisp_Marker, p);
2599 set_lheader_implementation(&p->lheader, &lrecord_marker);
2604 p->insertion_type = 0;
2609 /************************************************************************/
2610 /* String allocation */
2611 /************************************************************************/
2613 /* The data for "short" strings generally resides inside of structs of type
2614 string_chars_block. The Lisp_String structure is allocated just like any
2615 other Lisp object (except for vectors), and these are freelisted when
2616 they get garbage collected. The data for short strings get compacted,
2617 but the data for large strings do not.
2619 Previously Lisp_String structures were relocated, but this caused a lot
2620 of bus-errors because the C code didn't include enough GCPRO's for
2621 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
2622 that the reference would get relocated).
2624 This new method makes things somewhat bigger, but it is MUCH safer. */
2626 DECLARE_FIXED_TYPE_ALLOC(string, Lisp_String);
2627 /* strings are used and freed quite often */
2628 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
2629 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
2631 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && 0
2633 string_register_finaliser(Lisp_String *s)
2635 GC_finalization_proc *foo = NULL;
2637 auto void string_finaliser();
2639 auto void string_finaliser(void *obj, void *SXE_UNUSED(data))
2641 if (!(((Lisp_String*)obj)->lheader.c_readonly)) {
2642 yfree(((Lisp_String*)obj)->data);
2645 memset(obj, 0, sizeof(Lisp_String));
2649 SXE_DEBUG_GC("string-fina %p\n", s);
2650 GC_REGISTER_FINALIZER(s, string_finaliser, NULL, foo, bar);
2655 string_register_finaliser(Lisp_String *SXE_UNUSED(b))
2659 #endif /* HAVE_BDWGC */
2661 static Lisp_Object mark_string(Lisp_Object obj)
2663 Lisp_String *ptr = XSTRING(obj);
2665 if (CONSP(ptr->plist) && EXTENT_INFOP(XCAR(ptr->plist)))
2666 flush_cached_extent_info(XCAR(ptr->plist));
2667 #ifdef EF_USE_COMPRE
2668 mark_object(ptr->compre);
2673 static int string_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
2676 return (((len = XSTRING_LENGTH(obj1)) == XSTRING_LENGTH(obj2)) &&
2677 !memcmp(XSTRING_DATA(obj1), XSTRING_DATA(obj2), len));
2680 static const struct lrecord_description string_description[] = {
2681 {XD_BYTECOUNT, offsetof(Lisp_String, size)},
2682 {XD_OPAQUE_DATA_PTR, offsetof(Lisp_String, data), XD_INDIRECT(0, 1)},
2683 #ifdef EF_USE_COMPRE
2684 {XD_LISP_OBJECT, offsetof(Lisp_String, compre)},
2686 {XD_LISP_OBJECT, offsetof(Lisp_String, plist)},
2690 /* the seq implementation */
2692 str_length(const seq_t str)
2694 return string_char_length((const Lisp_String*)str);
2698 str_iter_init(seq_t str, seq_iter_t si)
2701 si->data = (void*)0;
2706 str_iter_next(seq_iter_t si, void **elt)
2708 if (si->seq != NULL &&
2709 (long int)si->data < string_char_length((Lisp_String*)si->seq)) {
2710 *elt = (void*)make_char(
2711 string_char((Lisp_String*)si->seq, (long int)si->data));
2712 si->data = (void*)((long int)si->data + 1);
2720 str_iter_fini(seq_iter_t si)
2722 si->data = si->seq = NULL;
2727 str_iter_reset(seq_iter_t si)
2729 si->data = (void*)0;
2734 str_explode(void *restrict tgt[], size_t ntgt, const seq_t s)
2736 size_t len = string_char_length((const Lisp_String*)s);
2737 volatile size_t i = 0;
2739 while (i < len && i < ntgt) {
2740 tgt[i] = (void*)make_char(string_char((Lisp_String*)s, i));
2746 static struct seq_impl_s __sstr = {
2747 .length_f = str_length,
2748 .iter_init_f = str_iter_init,
2749 .iter_next_f = str_iter_next,
2750 .iter_fini_f = str_iter_fini,
2751 .iter_reset_f = str_iter_reset,
2752 .explode_f = str_explode,
2756 /* We store the string's extent info as the first element of the string's
2757 property list; and the string's MODIFF as the first or second element
2758 of the string's property list (depending on whether the extent info
2759 is present), but only if the string has been modified. This is ugly
2760 but it reduces the memory allocated for the string in the vast
2761 majority of cases, where the string is never modified and has no
2764 #### This means you can't use an int as a key in a string's plist. */
2766 static Lisp_Object *string_plist_ptr(Lisp_Object string)
2768 Lisp_Object *ptr = &XSTRING(string)->plist;
2770 if (CONSP(*ptr) && EXTENT_INFOP(XCAR(*ptr)))
2772 if (CONSP(*ptr) && INTP(XCAR(*ptr)))
2777 static Lisp_Object string_getprop(Lisp_Object string, Lisp_Object property)
2779 return external_plist_get(string_plist_ptr(string), property, 0,
2784 string_putprop(Lisp_Object string, Lisp_Object property, Lisp_Object value)
2786 external_plist_put(string_plist_ptr(string), property, value, 0,
2791 static int string_remprop(Lisp_Object string, Lisp_Object property)
2793 return external_remprop(string_plist_ptr(string), property, 0,
2797 static Lisp_Object string_plist(Lisp_Object string)
2799 return *string_plist_ptr(string);
2802 /* No `finalize', or `hash' methods.
2803 internal_hash() already knows how to hash strings and finalization
2804 is done with the ADDITIONAL_FREE_string macro, which is the
2805 standard way to do finalization when using
2806 SWEEP_FIXED_TYPE_BLOCK(). */
2807 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS("string", string,
2808 mark_string, print_string,
2814 string_plist, Lisp_String);
2816 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2817 /* String blocks contain this many useful bytes. */
2818 #define STRING_CHARS_BLOCK_SIZE \
2819 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
2820 ((2 * sizeof (struct string_chars_block *)) \
2821 + sizeof (EMACS_INT))))
2822 /* Block header for small strings. */
2823 struct string_chars_block {
2825 struct string_chars_block *next;
2826 struct string_chars_block *prev;
2827 /* Contents of string_chars_block->string_chars are interleaved
2828 string_chars structures (see below) and the actual string data */
2829 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
2832 static struct string_chars_block *first_string_chars_block;
2833 static struct string_chars_block *current_string_chars_block;
2835 /* If SIZE is the length of a string, this returns how many bytes
2836 * the string occupies in string_chars_block->string_chars
2837 * (including alignment padding).
2839 #define STRING_FULLSIZE(size) \
2840 ALIGN_SIZE(((size) + 1 + sizeof(Lisp_String*)), ALIGNOF(Lisp_String*))
2842 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
2843 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
2845 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL)
2846 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL))
2848 struct string_chars {
2849 Lisp_String *string;
2850 unsigned char chars[1];
2853 struct unused_string_chars {
2854 Lisp_String *string;
2858 static void init_string_chars_alloc(void)
2860 first_string_chars_block = ynew(struct string_chars_block);
2861 first_string_chars_block->prev = 0;
2862 first_string_chars_block->next = 0;
2863 first_string_chars_block->pos = 0;
2864 current_string_chars_block = first_string_chars_block;
2867 static struct string_chars*
2868 allocate_string_chars_struct(Lisp_String *string_it_goes_with,
2871 struct string_chars *s_chars;
2873 if (fullsize <= (countof(current_string_chars_block->string_chars)
2874 - current_string_chars_block->pos)) {
2875 /* This string can fit in the current string chars block */
2876 s_chars = (struct string_chars *)
2877 (current_string_chars_block->string_chars
2878 + current_string_chars_block->pos);
2879 current_string_chars_block->pos += fullsize;
2881 /* Make a new current string chars block */
2882 struct string_chars_block *new_scb =
2883 ynew(struct string_chars_block);
2885 current_string_chars_block->next = new_scb;
2886 new_scb->prev = current_string_chars_block;
2888 current_string_chars_block = new_scb;
2889 new_scb->pos = fullsize;
2890 s_chars = (struct string_chars *)
2891 current_string_chars_block->string_chars;
2894 s_chars->string = string_it_goes_with;
2896 INCREMENT_CONS_COUNTER(fullsize, "string chars");
2902 Lisp_Object make_uninit_string(Bytecount length)
2904 Lisp_String *s = NULL;
2905 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2906 EMACS_INT fullsize = STRING_FULLSIZE(length);
2910 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
2911 assert(length >= 0 && fullsize > 0);
2914 /* Allocate the string header */
2915 ALLOCATE_FIXED_TYPE(string, Lisp_String, s);
2916 set_lheader_implementation(&s->lheader, &lrecord_string);
2917 string_register_finaliser(s);
2920 Bufbyte *foo = NULL;
2921 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
2922 foo = xnew_atomic_array(Bufbyte, length+1);
2923 assert(foo != NULL);
2925 if (BIG_STRING_FULLSIZE_P(fullsize)) {
2926 foo = xnew_atomic_array(Bufbyte, length + 1);
2927 assert(foo != NULL);
2929 foo = allocate_string_chars_struct(s, fullsize)->chars;
2930 assert(foo != NULL);
2933 set_string_data(s, foo);
2935 set_string_length(s, length);
2937 #ifdef EF_USE_COMPRE
2940 /* propagate the cat system, go with the standard impl of a seq first */
2941 s->lheader.morphisms = 0;
2943 set_string_byte(s, length, 0);
2949 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2950 static void verify_string_chars_integrity(void);
2953 /* Resize the string S so that DELTA bytes can be inserted starting
2954 at POS. If DELTA < 0, it means deletion starting at POS. If
2955 POS < 0, resize the string but don't copy any characters. Use
2956 this if you're planning on completely overwriting the string.
2959 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
2960 void resize_string(Lisp_String * s, Bytecount pos, Bytecount delta)
2965 /* trivial cases first */
2967 /* simplest case: no size change. */
2971 if (pos >= 0 && delta < 0) {
2972 /* If DELTA < 0, the functions below will delete the characters
2973 before POS. We want to delete characters *after* POS,
2974 however, so convert this to the appropriate form. */
2978 /* Both strings are big. We can just realloc().
2979 But careful! If the string is shrinking, we have to
2980 memmove() _before_ realloc(), and if growing, we have to
2981 memmove() _after_ realloc() - otherwise the access is
2982 illegal, and we might crash. */
2983 len = string_length(s) + 1 - pos;
2985 if (delta < 0 && pos >= 0) {
2986 memmove(string_data(s) + pos + delta,
2987 string_data(s) + pos, len);
2990 /* do the reallocation */
2991 foo = xrealloc(string_data(s), string_length(s) + delta + 1);
2992 set_string_data(s, foo);
2994 if (delta > 0 && pos >= 0) {
2995 memmove(string_data(s) + pos + delta,
2996 string_data(s) + pos, len);
2999 set_string_length(s, string_length(s) + delta);
3000 /* If pos < 0, the string won't be zero-terminated.
3001 Terminate now just to make sure. */
3002 string_data(s)[string_length(s)] = '\0';
3007 XSETSTRING(string, s);
3008 /* We also have to adjust all of the extent indices after the
3009 place we did the change. We say "pos - 1" because
3010 adjust_extents() is exclusive of the starting position
3012 adjust_extents(string, pos - 1, string_length(s), delta);
3016 #else /* !HAVE_BDWGC */
3017 void resize_string(Lisp_String * s, Bytecount pos, Bytecount delta)
3019 Bytecount oldfullsize, newfullsize;
3020 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3021 verify_string_chars_integrity();
3024 #ifdef ERROR_CHECK_BUFPOS
3026 assert(pos <= string_length(s));
3028 assert(pos + (-delta) <= string_length(s));
3031 assert((-delta) <= string_length(s));
3033 #endif /* ERROR_CHECK_BUFPOS */
3036 /* simplest case: no size change. */
3039 if (pos >= 0 && delta < 0)
3040 /* If DELTA < 0, the functions below will delete the characters
3041 before POS. We want to delete characters *after* POS, however,
3042 so convert this to the appropriate form. */
3045 oldfullsize = STRING_FULLSIZE(string_length(s));
3046 newfullsize = STRING_FULLSIZE(string_length(s) + delta);
3048 if (BIG_STRING_FULLSIZE_P(oldfullsize)) {
3049 if (BIG_STRING_FULLSIZE_P(newfullsize)) {
3050 /* Both strings are big. We can just realloc().
3051 But careful! If the string is shrinking, we have to
3052 memmove() _before_ realloc(), and if growing, we have to
3053 memmove() _after_ realloc() - otherwise the access is
3054 illegal, and we might crash. */
3055 Bytecount len = string_length(s) + 1 - pos;
3058 if (delta < 0 && pos >= 0)
3059 memmove(string_data(s) + pos + delta,
3060 string_data(s) + pos, len);
3062 foo = xrealloc(string_data(s),
3063 string_length(s) + delta + 1);
3064 set_string_data(s, foo);
3065 if (delta > 0 && pos >= 0) {
3066 memmove(string_data(s) + pos + delta,
3067 string_data(s) + pos, len);
3070 /* String has been demoted from BIG_STRING. */
3073 allocate_string_chars_struct(s, newfullsize)
3075 Bufbyte *old_data = string_data(s);
3078 memcpy(new_data, old_data, pos);
3079 memcpy(new_data + pos + delta, old_data + pos,
3080 string_length(s) + 1 - pos);
3082 set_string_data(s, new_data);
3085 } else { /* old string is small */
3087 if (oldfullsize == newfullsize) {
3088 /* special case; size change but the necessary
3089 allocation size won't change (up or down; code
3090 somewhere depends on there not being any unused
3091 allocation space, modulo any alignment
3094 Bufbyte *addroff = pos + string_data(s);
3096 memmove(addroff + delta, addroff,
3097 /* +1 due to zero-termination. */
3098 string_length(s) + 1 - pos);
3101 Bufbyte *old_data = string_data(s);
3102 Bufbyte *new_data = BIG_STRING_FULLSIZE_P(newfullsize)
3103 ? xnew_atomic_array(
3104 Bufbyte, string_length(s) + delta + 1)
3105 : allocate_string_chars_struct(
3106 s, newfullsize)->chars;
3109 memcpy(new_data, old_data, pos);
3110 memcpy(new_data + pos + delta, old_data + pos,
3111 string_length(s) + 1 - pos);
3113 set_string_data(s, new_data);
3116 /* We need to mark this chunk of the
3117 string_chars_block as unused so that
3118 compact_string_chars() doesn't freak. */
3119 struct string_chars *old_s_chars =
3120 (struct string_chars *)
3122 offsetof(struct string_chars, chars));
3123 /* Sanity check to make sure we aren't hosed by
3124 strange alignment/padding. */
3125 assert(old_s_chars->string == s);
3126 MARK_STRING_CHARS_AS_FREE(old_s_chars);
3127 ((struct unused_string_chars *)old_s_chars)->
3128 fullsize = oldfullsize;
3133 set_string_length(s, string_length(s) + delta);
3134 /* If pos < 0, the string won't be zero-terminated.
3135 Terminate now just to make sure. */
3136 string_data(s)[string_length(s)] = '\0';
3141 XSETSTRING(string, s);
3142 /* We also have to adjust all of the extent indices after the
3143 place we did the change. We say "pos - 1" because
3144 adjust_extents() is exclusive of the starting position
3146 adjust_extents(string, pos - 1, string_length(s), delta);
3148 #ifdef VERIFY_STRING_CHARS_INTEGRITY
3149 verify_string_chars_integrity();
3155 void set_string_char(Lisp_String * s, Charcount i, Emchar c)
3157 Bufbyte newstr[MAX_EMCHAR_LEN];
3158 Bytecount bytoff = charcount_to_bytecount(string_data(s), i);
3159 Bytecount oldlen = charcount_to_bytecount(string_data(s) + bytoff, 1);
3160 Bytecount newlen = set_charptr_emchar(newstr, c);
3162 if (oldlen != newlen) {
3163 resize_string(s, bytoff, newlen - oldlen);
3165 /* Remember, string_data (s) might have changed so we can't cache it. */
3166 memcpy(string_data(s) + bytoff, newstr, newlen);
3171 DEFUN("make-string", Fmake_string, 2, 2, 0, /*
3172 Return a new string consisting of LENGTH copies of CHARACTER.
3173 LENGTH must be a non-negative integer.
3175 (length, character))
3177 CHECK_NATNUM(length);
3178 CHECK_CHAR_COERCE_INT(character);
3180 Bufbyte init_str[MAX_EMCHAR_LEN];
3181 int len = set_charptr_emchar(init_str, XCHAR(character));
3182 Lisp_Object val = make_uninit_string(len * XINT(length));
3185 /* Optimize the single-byte case */
3186 memset(XSTRING_DATA(val), XCHAR(character),
3187 XSTRING_LENGTH(val));
3190 Bufbyte *ptr = XSTRING_DATA(val);
3192 for (i = XINT(length); i; i--) {
3193 Bufbyte *init_ptr = init_str;
3196 *ptr++ = *init_ptr++;
3198 *ptr++ = *init_ptr++;
3200 *ptr++ = *init_ptr++;
3202 *ptr++ = *init_ptr++;
3212 DEFUN("string", Fstring, 0, MANY, 0, /*
3213 Concatenate all the argument characters and make the result a string.
3215 (int nargs, Lisp_Object * args))
3217 Bufbyte *storage, *p;
3219 int speccount = specpdl_depth();
3220 int len = nargs * MAX_EMCHAR_LEN;
3222 XMALLOC_OR_ALLOCA(storage, len, Bufbyte);
3224 for (; nargs; nargs--, args++) {
3225 Lisp_Object lisp_char = *args;
3226 CHECK_CHAR_COERCE_INT(lisp_char);
3227 p += set_charptr_emchar(p, XCHAR(lisp_char));
3229 result = make_string(storage, p - storage);
3230 XMALLOC_UNBIND(storage, len, speccount );
3235 /* Take some raw memory, which MUST already be in internal format,
3236 and package it up into a Lisp string. */
3238 make_string(const Bufbyte *contents, Bytecount length)
3242 /* Make sure we find out about bad make_string's when they happen */
3243 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
3244 /* Just for the assertions */
3245 bytecount_to_charcount(contents, length);
3248 val = make_uninit_string(length);
3249 memcpy(XSTRING_DATA(val), contents, length);
3253 /* Take some raw memory, encoded in some external data format,
3254 and convert it into a Lisp string. */
3256 make_ext_string(const Extbyte *contents, EMACS_INT length,
3257 Lisp_Object coding_system)
3260 TO_INTERNAL_FORMAT(DATA, (contents, length),
3261 LISP_STRING, string, coding_system);
3265 /* why arent the next 3 inlines? */
3266 Lisp_Object build_string(const char *str)
3268 /* Some strlen's crash and burn if passed null. */
3270 return make_string((const Bufbyte*)str, strlen(str));
3276 Lisp_Object build_ext_string(const char *str, Lisp_Object coding_system)
3278 /* Some strlen's crash and burn if passed null. */
3279 return make_ext_string((const Extbyte*)str, (str ? strlen(str) : 0), coding_system);
3282 Lisp_Object build_translated_string(const char *str)
3284 return build_string(GETTEXT(str));
3287 Lisp_Object make_string_nocopy(Bufbyte *contents, Bytecount length)
3292 /* Make sure we find out about bad make_string_nocopy's when they
3294 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
3295 /* Just for the assertions */
3296 bytecount_to_charcount(contents, length);
3299 /* Allocate the string header */
3300 ALLOCATE_FIXED_TYPE(string, Lisp_String, s);
3301 set_lheader_implementation(&s->lheader, &lrecord_string);
3302 SET_C_READONLY_RECORD_HEADER(&s->lheader);
3303 string_register_finaliser(s);
3306 #ifdef EF_USE_COMPRE
3309 set_string_data(s, contents);
3310 set_string_length(s, length);
3316 /************************************************************************/
3317 /* lcrecord lists */
3318 /************************************************************************/
3320 /* Lcrecord lists are used to manage the allocation of particular
3321 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
3322 malloc() and garbage-collection junk) as much as possible.
3323 It is similar to the Blocktype class.
3327 1) Create an lcrecord-list object using make_lcrecord_list().
3328 This is often done at initialization. Remember to staticpro_nodump
3329 this object! The arguments to make_lcrecord_list() are the
3330 same as would be passed to alloc_lcrecord().
3331 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
3332 and pass the lcrecord-list earlier created.
3333 3) When done with the lcrecord, call free_managed_lcrecord().
3334 The standard freeing caveats apply: ** make sure there are no
3335 pointers to the object anywhere! **
3336 4) Calling free_managed_lcrecord() is just like kissing the
3337 lcrecord goodbye as if it were garbage-collected. This means:
3338 -- the contents of the freed lcrecord are undefined, and the
3339 contents of something produced by allocate_managed_lcrecord()
3340 are undefined, just like for alloc_lcrecord().
3341 -- the mark method for the lcrecord's type will *NEVER* be called
3343 -- the finalize method for the lcrecord's type will be called
3344 at the time that free_managed_lcrecord() is called.
3346 lcrecord lists do not work in bdwgc mode. -hrop
3350 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3352 mark_lcrecord_list(Lisp_Object obj)
3357 /* just imitate the lcrecord spectactular */
3359 make_lcrecord_list(size_t size,
3360 const struct lrecord_implementation *implementation)
3362 struct lcrecord_list *p =
3363 alloc_lcrecord_type(struct lcrecord_list,
3364 &lrecord_lcrecord_list);
3367 p->implementation = implementation;
3370 XSETLCRECORD_LIST(val, p);
3375 allocate_managed_lcrecord(Lisp_Object lcrecord_list)
3377 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3378 void *tmp = alloc_lcrecord(list->size, list->implementation);
3386 free_managed_lcrecord(Lisp_Object SXE_UNUSED(lcrecord_list), Lisp_Object lcrecord)
3388 struct free_lcrecord_header *free_header =
3389 (struct free_lcrecord_header*)XPNTR(lcrecord);
3390 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3391 const struct lrecord_implementation *imp =
3392 LHEADER_IMPLEMENTATION(lheader);
3394 if (imp->finalizer) {
3395 imp->finalizer(lheader, 0);
3403 mark_lcrecord_list(Lisp_Object obj)
3405 struct lcrecord_list *list = XLCRECORD_LIST(obj);
3406 Lisp_Object chain = list->free;
3408 while (!NILP(chain)) {
3409 struct lrecord_header *lheader = XRECORD_LHEADER(chain);
3410 struct free_lcrecord_header *free_header =
3411 (struct free_lcrecord_header *)lheader;
3414 /* There should be no other pointers to the free list. */
3415 !MARKED_RECORD_HEADER_P(lheader)
3417 /* Only lcrecords should be here. */
3418 !LHEADER_IMPLEMENTATION(lheader)->
3420 /* Only free lcrecords should be here. */
3421 free_header->lcheader.free &&
3422 /* The type of the lcrecord must be right. */
3423 LHEADER_IMPLEMENTATION(lheader) ==
3424 list->implementation &&
3425 /* So must the size. */
3426 (LHEADER_IMPLEMENTATION(lheader)->
3428 || LHEADER_IMPLEMENTATION(lheader)->
3429 static_size == list->size)
3432 MARK_RECORD_HEADER(lheader);
3433 chain = free_header->chain;
3440 make_lcrecord_list(size_t size,
3441 const struct lrecord_implementation *implementation)
3443 struct lcrecord_list *p =
3444 alloc_lcrecord_type(struct lcrecord_list,
3445 &lrecord_lcrecord_list);
3448 p->implementation = implementation;
3451 XSETLCRECORD_LIST(val, p);
3456 allocate_managed_lcrecord(Lisp_Object lcrecord_list)
3458 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3459 if (!NILP(list->free)) {
3460 Lisp_Object val = list->free;
3461 struct free_lcrecord_header *free_header =
3462 (struct free_lcrecord_header *)XPNTR(val);
3464 #ifdef ERROR_CHECK_GC
3465 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3467 /* There should be no other pointers to the free list. */
3468 assert(!MARKED_RECORD_HEADER_P(lheader));
3469 /* Only lcrecords should be here. */
3470 assert(!LHEADER_IMPLEMENTATION(lheader)->basic_p);
3471 /* Only free lcrecords should be here. */
3472 assert(free_header->lcheader.free);
3473 /* The type of the lcrecord must be right. */
3474 assert(LHEADER_IMPLEMENTATION(lheader) == list->implementation);
3475 /* So must the size. */
3476 assert(LHEADER_IMPLEMENTATION(lheader)->static_size == 0 ||
3477 LHEADER_IMPLEMENTATION(lheader)->static_size ==
3479 #endif /* ERROR_CHECK_GC */
3481 list->free = free_header->chain;
3482 free_header->lcheader.free = 0;
3485 void *tmp = alloc_lcrecord(list->size, list->implementation);
3494 free_managed_lcrecord(Lisp_Object lcrecord_list, Lisp_Object lcrecord)
3496 struct lcrecord_list *list = XLCRECORD_LIST(lcrecord_list);
3497 struct free_lcrecord_header *free_header =
3498 (struct free_lcrecord_header*)XPNTR(lcrecord);
3499 struct lrecord_header *lheader = &free_header->lcheader.lheader;
3500 const struct lrecord_implementation *implementation
3501 = LHEADER_IMPLEMENTATION(lheader);
3503 /* Make sure the size is correct. This will catch, for example,
3504 putting a window configuration on the wrong free list. */
3505 gc_checking_assert((implementation->size_in_bytes_method ?
3506 implementation->size_in_bytes_method(lheader) :
3507 implementation->static_size)
3510 if (implementation->finalizer) {
3511 implementation->finalizer(lheader, 0);
3513 free_header->chain = list->free;
3514 free_header->lcheader.free = 1;
3515 list->free = lcrecord;
3519 DEFINE_LRECORD_IMPLEMENTATION("lcrecord-list", lcrecord_list,
3520 mark_lcrecord_list, internal_object_printer,
3521 0, 0, 0, 0, struct lcrecord_list);
3524 DEFUN("purecopy", Fpurecopy, 1, 1, 0, /*
3525 Kept for compatibility, returns its argument.
3527 Make a copy of OBJECT in pure storage.
3528 Recursively copies contents of vectors and cons cells.
3529 Does not copy symbols.
3536 /************************************************************************/
3537 /* Garbage Collection */
3538 /************************************************************************/
3540 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
3541 Additional ones may be defined by a module (none yet). We leave some
3542 room in `lrecord_implementations_table' for such new lisp object types. */
3543 const struct lrecord_implementation
3544 *lrecord_implementations_table[(unsigned int)lrecord_type_last_built_in_type
3545 + MODULE_DEFINABLE_TYPE_COUNT];
3546 unsigned int lrecord_type_count = (unsigned int)lrecord_type_last_built_in_type;
3547 /* Object marker functions are in the lrecord_implementation structure.
3548 But copying them to a parallel array is much more cache-friendly.
3549 This hack speeds up (garbage-collect) by about 5%. */
3550 Lisp_Object(*lrecord_markers[countof(lrecord_implementations_table)])
3553 #ifndef EF_USE_ASYNEQ
3554 struct gcpro *gcprolist;
3557 /* We want the staticpros relocated, but not the pointers found therein.
3558 Hence we use a trivial description, as for pointerless objects. */
3559 static const struct lrecord_description staticpro_description_1[] = {
3563 static const struct struct_description staticpro_description = {
3564 sizeof(Lisp_Object *),
3565 staticpro_description_1
3568 static const struct lrecord_description staticpros_description_1[] = {
3569 XD_DYNARR_DESC(Lisp_Object_ptr_dynarr, &staticpro_description),
3573 static const struct struct_description staticpros_description = {
3574 sizeof(Lisp_Object_ptr_dynarr),
3575 staticpros_description_1
3578 Lisp_Object_ptr_dynarr *staticpros;
3580 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
3581 garbage collection, and for dumping. */
3582 void staticpro(Lisp_Object * varaddress)
3585 Dynarr_add(staticpros, varaddress);
3586 dump_add_root_object(varaddress);
3590 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3591 Lisp_Object_ptr_dynarr *staticpros_nodump;
3593 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
3594 garbage collection, but not for dumping. */
3595 void staticpro_nodump(Lisp_Object * varaddress)
3598 Dynarr_add(staticpros_nodump, varaddress);
3604 #ifdef ERROR_CHECK_GC
3605 #define GC_CHECK_LHEADER_INVARIANTS(lheader) \
3607 struct lrecord_header * GCLI_lh = (lheader); \
3608 assert (GCLI_lh != 0); \
3609 assert (GCLI_lh->type < lrecord_type_count); \
3610 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
3611 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
3612 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
3615 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
3618 /* Mark reference to a Lisp_Object. If the object referred to has not been
3619 seen yet, recursively mark all the references contained in it. */
3621 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3622 void mark_object(Lisp_Object SXE_UNUSED(obj))
3628 void mark_object(Lisp_Object obj)
3630 if (obj == Qnull_pointer) {
3635 /* Checks we used to perform */
3636 /* if (EQ (obj, Qnull_pointer)) return; */
3637 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
3638 /* if (PURIFIED (XPNTR (obj))) return; */
3640 if (XTYPE(obj) == Lisp_Type_Record) {
3641 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
3643 GC_CHECK_LHEADER_INVARIANTS(lheader);
3645 gc_checking_assert(LHEADER_IMPLEMENTATION(lheader)->basic_p ||
3646 !((struct lcrecord_header *)lheader)->free);
3648 /* All c_readonly objects have their mark bit set,
3649 so that we only need to check the mark bit here. */
3650 if (!MARKED_RECORD_HEADER_P(lheader)) {
3651 MARK_RECORD_HEADER(lheader);
3653 if (RECORD_MARKER(lheader)) {
3654 obj = RECORD_MARKER(lheader) (obj);
3663 /* mark all of the conses in a list and mark the final cdr; but
3664 DO NOT mark the cars.
3666 Use only for internal lists! There should never be other pointers
3667 to the cons cells, because if so, the cars will remain unmarked
3668 even when they maybe should be marked. */
3669 void mark_conses_in_list(Lisp_Object obj)
3673 for (rest = obj; CONSP(rest); rest = XCDR(rest)) {
3674 if (CONS_MARKED_P(XCONS(rest)))
3676 MARK_CONS(XCONS(rest));
3682 /* Find all structures not marked, and free them. */
3684 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3685 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
3686 static int gc_count_bit_vector_storage;
3687 static int gc_count_num_short_string_in_use;
3688 static int gc_count_string_total_size;
3689 static int gc_count_short_string_total_size;
3692 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3694 /* stats on lcrecords in use - kinda kludgy */
3696 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3698 int instances_in_use;
3700 int instances_freed;
3702 int instances_on_free_list;
3703 } lcrecord_stats[countof(lrecord_implementations_table)
3704 + MODULE_DEFINABLE_TYPE_COUNT];
3707 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3708 static void tick_lcrecord_stats(const struct lrecord_header *h, int free_p)
3710 unsigned int type_index = h->type;
3712 if (((const struct lcrecord_header *)h)->free) {
3713 gc_checking_assert(!free_p);
3714 lcrecord_stats[type_index].instances_on_free_list++;
3716 const struct lrecord_implementation *implementation =
3717 LHEADER_IMPLEMENTATION(h);
3719 size_t sz = (implementation->size_in_bytes_method ?
3720 implementation->size_in_bytes_method(h) :
3721 implementation->static_size);
3723 lcrecord_stats[type_index].instances_freed++;
3724 lcrecord_stats[type_index].bytes_freed += sz;
3726 lcrecord_stats[type_index].instances_in_use++;
3727 lcrecord_stats[type_index].bytes_in_use += sz;
3733 /* Free all unmarked records */
3734 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3736 sweep_lcrecords_1(struct lcrecord_header *volatile*prev, int *used)
3739 /* int total_size = 0; */
3741 xzero(lcrecord_stats); /* Reset all statistics to 0. */
3743 /* First go through and call all the finalize methods.
3744 Then go through and free the objects. There used to
3745 be only one loop here, with the call to the finalizer
3746 occurring directly before the xfree() below. That
3747 is marginally faster but much less safe -- if the
3748 finalize method for an object needs to reference any
3749 other objects contained within it (and many do),
3750 we could easily be screwed by having already freed that
3753 for (struct lcrecord_header *volatile header = *prev;
3754 header; header = header->next) {
3755 struct lrecord_header *h = &(header->lheader);
3757 GC_CHECK_LHEADER_INVARIANTS(h);
3759 if (!MARKED_RECORD_HEADER_P(h) && !header->free) {
3760 if (LHEADER_IMPLEMENTATION(h)->finalizer)
3761 LHEADER_IMPLEMENTATION(h)->finalizer(h, 0);
3765 for (struct lcrecord_header *volatile header = *prev; header;) {
3766 struct lrecord_header *volatile h = &(header->lheader);
3767 if (MARKED_RECORD_HEADER_P(h)) {
3768 if (!C_READONLY_RECORD_HEADER_P(h))
3769 UNMARK_RECORD_HEADER(h);
3771 /* total_size += n->implementation->size_in_bytes (h); */
3772 /* #### May modify header->next on a C_READONLY lcrecord */
3773 prev = &(header->next);
3775 tick_lcrecord_stats(h, 0);
3777 struct lcrecord_header *next = header->next;
3779 tick_lcrecord_stats(h, 1);
3780 /* used to call finalizer right here. */
3786 /* *total = total_size; */
3791 sweep_bit_vectors_1(Lisp_Object * prev, int *used, int *total, int *storage)
3793 Lisp_Object bit_vector;
3796 int total_storage = 0;
3798 /* BIT_VECTORP fails because the objects are marked, which changes
3799 their implementation */
3800 for (bit_vector = *prev; !EQ(bit_vector, Qzero);) {
3801 Lisp_Bit_Vector *v = XBIT_VECTOR(bit_vector);
3803 if (MARKED_RECORD_P(bit_vector)) {
3804 if (!C_READONLY_RECORD_HEADER_P(&(v->lheader)))
3805 UNMARK_RECORD_HEADER(&(v->lheader));
3809 FLEXIBLE_ARRAY_STRUCT_SIZEOF(Lisp_Bit_Vector,
3810 unsigned long, bits,
3811 BIT_VECTOR_LONG_STORAGE
3814 /* #### May modify next on a C_READONLY bitvector */
3815 prev = &(bit_vector_next(v));
3818 Lisp_Object next = bit_vector_next(v);
3825 *total = total_size;
3826 *storage = total_storage;
3830 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3831 to make macros prettier. */
3833 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
3834 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type)
3836 #elif defined ERROR_CHECK_GC
3838 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3840 struct typename##_block *SFTB_current; \
3842 int num_free = 0, num_used = 0; \
3844 for (SFTB_current = current_##typename##_block, \
3845 SFTB_limit = current_##typename##_block_index; \
3850 for (SFTB_iii = 0; \
3851 SFTB_iii < SFTB_limit; \
3853 obj_type *SFTB_victim = \
3854 &(SFTB_current->block[SFTB_iii]); \
3856 if (LRECORD_FREE_P (SFTB_victim)) { \
3858 } else if (C_READONLY_RECORD_HEADER_P \
3859 (&SFTB_victim->lheader)) { \
3861 } else if (!MARKED_RECORD_HEADER_P \
3862 (&SFTB_victim->lheader)) { \
3864 FREE_FIXED_TYPE(typename, obj_type, \
3868 UNMARK_##typename(SFTB_victim); \
3871 SFTB_current = SFTB_current->prev; \
3872 SFTB_limit = countof(current_##typename##_block \
3876 gc_count_num_##typename##_in_use = num_used; \
3877 gc_count_num_##typename##_freelist = num_free; \
3880 #else /* !ERROR_CHECK_GC, !BDWGC*/
3882 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3884 struct typename##_block *SFTB_current; \
3885 struct typename##_block **SFTB_prev; \
3887 int num_free = 0, num_used = 0; \
3889 typename##_free_list = 0; \
3891 for (SFTB_prev = ¤t_##typename##_block, \
3892 SFTB_current = current_##typename##_block, \
3893 SFTB_limit = current_##typename##_block_index; \
3897 int SFTB_empty = 1; \
3898 Lisp_Free *SFTB_old_free_list = \
3899 typename##_free_list; \
3901 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; \
3903 obj_type *SFTB_victim = \
3904 &(SFTB_current->block[SFTB_iii]); \
3906 if (LRECORD_FREE_P (SFTB_victim)) { \
3908 PUT_FIXED_TYPE_ON_FREE_LIST \
3909 (typename, obj_type, \
3911 } else if (C_READONLY_RECORD_HEADER_P \
3912 (&SFTB_victim->lheader)) { \
3915 } else if (! MARKED_RECORD_HEADER_P \
3916 (&SFTB_victim->lheader)) { \
3918 FREE_FIXED_TYPE(typename, obj_type, \
3923 UNMARK_##typename (SFTB_victim); \
3926 if (!SFTB_empty) { \
3927 SFTB_prev = &(SFTB_current->prev); \
3928 SFTB_current = SFTB_current->prev; \
3929 } else if (SFTB_current == current_##typename##_block \
3930 && !SFTB_current->prev) { \
3931 /* No real point in freeing sole \
3932 * allocation block */ \
3935 struct typename##_block *SFTB_victim_block = \
3937 if (SFTB_victim_block == \
3938 current_##typename##_block) { \
3939 current_##typename##_block_index \
3941 (current_##typename##_block \
3944 SFTB_current = SFTB_current->prev; \
3946 *SFTB_prev = SFTB_current; \
3947 xfree(SFTB_victim_block); \
3948 /* Restore free list to what it was \
3949 before victim was swept */ \
3950 typename##_free_list = \
3951 SFTB_old_free_list; \
3952 num_free -= SFTB_limit; \
3955 SFTB_limit = countof (current_##typename##_block \
3959 gc_count_num_##typename##_in_use = num_used; \
3960 gc_count_num_##typename##_freelist = num_free; \
3963 #endif /* !ERROR_CHECK_GC */
3965 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3966 static void sweep_conses(void)
3968 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3969 #define ADDITIONAL_FREE_cons(ptr)
3971 SWEEP_FIXED_TYPE_BLOCK(cons, Lisp_Cons);
3975 /* Explicitly free a cons cell. */
3976 void free_cons(Lisp_Cons * ptr)
3978 #ifdef ERROR_CHECK_GC
3979 /* If the CAR is not an int, then it will be a pointer, which will
3980 always be four-byte aligned. If this cons cell has already been
3981 placed on the free list, however, its car will probably contain
3982 a chain pointer to the next cons on the list, which has cleverly
3983 had all its 0's and 1's inverted. This allows for a quick
3984 check to make sure we're not freeing something already freed. */
3985 if (POINTER_TYPE_P(XTYPE(ptr->car)))
3986 ASSERT_VALID_POINTER(XPNTR(ptr->car));
3987 #endif /* ERROR_CHECK_GC */
3989 #ifndef ALLOC_NO_POOLS
3990 FREE_FIXED_TYPE_WHEN_NOT_IN_GC(cons, Lisp_Cons, ptr);
3991 #endif /* ALLOC_NO_POOLS */
3994 /* explicitly free a list. You **must make sure** that you have
3995 created all the cons cells that make up this list and that there
3996 are no pointers to any of these cons cells anywhere else. If there
3997 are, you will lose. */
3999 void free_list(Lisp_Object list)
4001 Lisp_Object rest, next;
4003 for (rest = list; !NILP(rest); rest = next) {
4005 free_cons(XCONS(rest));
4009 /* explicitly free an alist. You **must make sure** that you have
4010 created all the cons cells that make up this alist and that there
4011 are no pointers to any of these cons cells anywhere else. If there
4012 are, you will lose. */
4014 void free_alist(Lisp_Object alist)
4016 Lisp_Object rest, next;
4018 for (rest = alist; !NILP(rest); rest = next) {
4020 free_cons(XCONS(XCAR(rest)));
4021 free_cons(XCONS(rest));
4025 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4026 static void sweep_compiled_functions(void)
4028 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4029 #define ADDITIONAL_FREE_compiled_function(ptr)
4031 SWEEP_FIXED_TYPE_BLOCK(compiled_function, Lisp_Compiled_Function);
4035 static void sweep_floats(void)
4037 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4038 #define ADDITIONAL_FREE_float(ptr)
4040 SWEEP_FIXED_TYPE_BLOCK(float, Lisp_Float);
4042 #endif /* HAVE_FPFLOAT */
4044 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
4048 #define UNMARK_bigz(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4049 #define ADDITIONAL_FREE_bigz(ptr) bigz_fini(ptr->data)
4051 SWEEP_FIXED_TYPE_BLOCK(bigz, Lisp_Bigz);
4053 #endif /* HAVE_MPZ */
4055 #if defined HAVE_MPQ && defined WITH_GMP
4059 #define UNMARK_bigq(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4060 #define ADDITIONAL_FREE_bigq(ptr) bigq_fini(ptr->data)
4062 SWEEP_FIXED_TYPE_BLOCK(bigq, Lisp_Bigq);
4064 #endif /* HAVE_MPQ */
4066 #if defined HAVE_MPF && defined WITH_GMP
4070 #define UNMARK_bigf(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4071 #define ADDITIONAL_FREE_bigf(ptr) bigf_fini(ptr->data)
4073 SWEEP_FIXED_TYPE_BLOCK(bigf, Lisp_Bigf);
4075 #endif /* HAVE_MPF */
4077 #if defined HAVE_MPFR && defined WITH_MPFR
4081 #define UNMARK_bigfr(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4082 #define ADDITIONAL_FREE_bigfr(ptr) bigfr_fini(ptr->data)
4084 SWEEP_FIXED_TYPE_BLOCK(bigfr, Lisp_Bigfr);
4086 #endif /* HAVE_MPFR */
4088 #if defined HAVE_PSEUG && defined WITH_PSEUG
4092 #define UNMARK_bigg(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4093 #define ADDITIONAL_FREE_bigg(ptr) bigg_fini(ptr->data)
4095 SWEEP_FIXED_TYPE_BLOCK(bigg, Lisp_Bigg);
4097 #endif /* HAVE_PSEUG */
4099 #if defined HAVE_MPC && defined WITH_MPC || \
4100 defined HAVE_PSEUC && defined WITH_PSEUC
4104 #define UNMARK_bigc(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4105 #define ADDITIONAL_FREE_bigc(ptr) bigc_fini(ptr->data)
4107 SWEEP_FIXED_TYPE_BLOCK(bigc, Lisp_Bigc);
4109 #endif /* HAVE_MPC */
4111 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
4113 sweep_quaterns (void)
4115 #define UNMARK_quatern(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4116 #define ADDITIONAL_FREE_quatern(ptr) quatern_fini(ptr->data)
4118 SWEEP_FIXED_TYPE_BLOCK(quatern, Lisp_Quatern);
4120 #endif /* HAVE_QUATERN */
4123 sweep_dynacats(void)
4125 #define UNMARK_dynacat(ptr) UNMARK_RECORD_HEADER(&((ptr)->lheader))
4126 #define ADDITIONAL_FREE_dynacat(ptr) dynacat_fini(ptr);
4128 SWEEP_FIXED_TYPE_BLOCK(dynacat, struct dynacat_s);
4131 static void sweep_symbols(void)
4133 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4134 #define ADDITIONAL_FREE_symbol(ptr)
4136 SWEEP_FIXED_TYPE_BLOCK(symbol, Lisp_Symbol);
4139 static void sweep_extents(void)
4141 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4142 #define ADDITIONAL_FREE_extent(ptr)
4144 SWEEP_FIXED_TYPE_BLOCK(extent, struct extent);
4147 static void sweep_events(void)
4149 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4150 #define ADDITIONAL_FREE_event(ptr)
4152 SWEEP_FIXED_TYPE_BLOCK(event, Lisp_Event);
4155 static void sweep_markers(void)
4157 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
4158 #define ADDITIONAL_FREE_marker(ptr) \
4159 do { Lisp_Object tem; \
4160 XSETMARKER (tem, ptr); \
4161 unchain_marker (tem); \
4164 SWEEP_FIXED_TYPE_BLOCK(marker, Lisp_Marker);
4168 /* Explicitly free a marker. */
4169 void free_marker(Lisp_Marker * ptr)
4171 /* Perhaps this will catch freeing an already-freed marker. */
4172 gc_checking_assert(ptr->lheader.type == lrecord_type_marker);
4174 #ifndef ALLOC_NO_POOLS
4175 FREE_FIXED_TYPE_WHEN_NOT_IN_GC(marker, Lisp_Marker, ptr);
4176 #endif /* ALLOC_NO_POOLS */
4179 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
4181 static void verify_string_chars_integrity(void)
4183 struct string_chars_block *sb;
4185 /* Scan each existing string block sequentially, string by string. */
4186 for (sb = first_string_chars_block; sb; sb = sb->next) {
4188 /* POS is the index of the next string in the block. */
4189 while (pos < sb->pos) {
4190 struct string_chars *s_chars =
4191 (struct string_chars *)&(sb->string_chars[pos]);
4192 Lisp_String *string;
4196 /* If the string_chars struct is marked as free (i.e. the
4197 STRING pointer is NULL) then this is an unused chunk of
4198 string storage. (See below.) */
4200 if (STRING_CHARS_FREE_P(s_chars)) {
4202 ((struct unused_string_chars *)s_chars)->
4208 string = s_chars->string;
4209 /* Must be 32-bit aligned. */
4210 assert((((int)string) & 3) == 0);
4212 size = string_length(string);
4213 fullsize = STRING_FULLSIZE(size);
4215 assert(!BIG_STRING_FULLSIZE_P(fullsize));
4216 assert(string_data(string) == s_chars->chars);
4219 assert(pos == sb->pos);
4223 #endif /* MULE && ERROR_CHECK_GC */
4225 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4226 /* Compactify string chars, relocating the reference to each --
4227 free any empty string_chars_block we see. */
4228 static void compact_string_chars(void)
4230 struct string_chars_block *to_sb = first_string_chars_block;
4232 struct string_chars_block *from_sb;
4234 /* Scan each existing string block sequentially, string by string. */
4235 for (from_sb = first_string_chars_block; from_sb;
4236 from_sb = from_sb->next) {
4238 /* FROM_POS is the index of the next string in the block. */
4239 while (from_pos < from_sb->pos) {
4240 struct string_chars *from_s_chars =
4241 (struct string_chars *)&(from_sb->
4242 string_chars[from_pos]);
4243 struct string_chars *to_s_chars;
4244 Lisp_String *string;
4248 /* If the string_chars struct is marked as free (i.e. the
4249 STRING pointer is NULL) then this is an unused chunk of
4250 string storage. This happens under Mule when a string's
4251 size changes in such a way that its fullsize changes.
4252 (Strings can change size because a different-length
4253 character can be substituted for another character.)
4254 In this case, after the bogus string pointer is the
4255 "fullsize" of this entry, i.e. how many bytes to skip. */
4257 if (STRING_CHARS_FREE_P(from_s_chars)) {
4259 ((struct unused_string_chars *)
4260 from_s_chars)->fullsize;
4261 from_pos += fullsize;
4265 string = from_s_chars->string;
4266 assert(!(LRECORD_FREE_P(string)));
4268 size = string_length(string);
4269 fullsize = STRING_FULLSIZE(size);
4271 gc_checking_assert(!BIG_STRING_FULLSIZE_P(fullsize));
4273 /* Just skip it if it isn't marked. */
4274 if (!MARKED_RECORD_HEADER_P(&(string->lheader))) {
4275 from_pos += fullsize;
4279 /* If it won't fit in what's left of TO_SB, close TO_SB
4280 out and go on to the next string_chars_block. We
4281 know that TO_SB cannot advance past FROM_SB here
4282 since FROM_SB is large enough to currently contain
4284 if ((to_pos + fullsize) >
4285 countof(to_sb->string_chars)) {
4286 to_sb->pos = to_pos;
4287 to_sb = to_sb->next;
4291 /* Compute new address of this string
4292 and update TO_POS for the space being used. */
4294 (struct string_chars *)&(to_sb->
4295 string_chars[to_pos]);
4297 /* Copy the string_chars to the new place. */
4298 if (from_s_chars != to_s_chars)
4299 memmove(to_s_chars, from_s_chars, fullsize);
4301 /* Relocate FROM_S_CHARS's reference */
4302 set_string_data(string, &(to_s_chars->chars[0]));
4304 from_pos += fullsize;
4309 /* Set current to the last string chars block still used and
4310 free any that follow. */
4311 for (volatile struct string_chars_block *victim = to_sb->next;
4313 volatile struct string_chars_block *tofree = victim;
4314 victim = victim->next;
4318 current_string_chars_block = to_sb;
4319 current_string_chars_block->pos = to_pos;
4320 current_string_chars_block->next = 0;
4323 static int debug_string_purity;
4325 static void debug_string_purity_print(Lisp_String * p)
4328 Charcount s = string_char_length(p);
4330 for (i = 0; i < s; i++) {
4331 Emchar ch = string_char(p, i);
4332 if (ch < 32 || ch >= 126)
4333 stderr_out("\\%03o", ch);
4334 else if (ch == '\\' || ch == '\"')
4335 stderr_out("\\%c", ch);
4337 stderr_out("%c", ch);
4343 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4344 static void sweep_strings(void)
4346 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
4347 int debug = debug_string_purity;
4349 #define UNMARK_string(ptr) \
4351 Lisp_String *p = (ptr); \
4352 size_t size = string_length (p); \
4353 UNMARK_RECORD_HEADER (&(p->lheader)); \
4354 num_bytes += size; \
4355 if (!BIG_STRING_SIZE_P (size)) { \
4356 num_small_bytes += size; \
4360 debug_string_purity_print (p); \
4362 #define ADDITIONAL_FREE_string(ptr) \
4364 size_t size = string_length (ptr); \
4365 if (BIG_STRING_SIZE_P(size)) { \
4370 SWEEP_FIXED_TYPE_BLOCK(string, Lisp_String);
4372 gc_count_num_short_string_in_use = num_small_used;
4373 gc_count_string_total_size = num_bytes;
4374 gc_count_short_string_total_size = num_small_bytes;
4378 /* I hate duplicating all this crap! */
4379 int marked_p(Lisp_Object obj)
4381 /* Checks we used to perform. */
4382 /* if (EQ (obj, Qnull_pointer)) return 1; */
4383 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
4384 /* if (PURIFIED (XPNTR (obj))) return 1; */
4386 if (XTYPE(obj) == Lisp_Type_Record) {
4387 struct lrecord_header *lheader = XRECORD_LHEADER(obj);
4389 GC_CHECK_LHEADER_INVARIANTS(lheader);
4391 return MARKED_RECORD_HEADER_P(lheader);
4396 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4397 static void gc_sweep(void)
4399 /* Free all unmarked records. Do this at the very beginning,
4400 before anything else, so that the finalize methods can safely
4401 examine items in the objects. sweep_lcrecords_1() makes
4402 sure to call all the finalize methods *before* freeing anything,
4403 to complete the safety. */
4406 sweep_lcrecords_1(&all_lcrecords, &ignored);
4409 compact_string_chars();
4411 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
4412 macros) must be *extremely* careful to make sure they're not
4413 referencing freed objects. The only two existing finalize
4414 methods (for strings and markers) pass muster -- the string
4415 finalizer doesn't look at anything but its own specially-
4416 created block, and the marker finalizer only looks at live
4417 buffers (which will never be freed) and at the markers before
4418 and after it in the chain (which, by induction, will never be
4419 freed because if so, they would have already removed themselves
4422 /* Put all unmarked strings on free list, free'ing the string chars
4423 of large unmarked strings */
4426 /* Put all unmarked conses on free list */
4429 /* Free all unmarked bit vectors */
4430 sweep_bit_vectors_1(&all_bit_vectors,
4431 &gc_count_num_bit_vector_used,
4432 &gc_count_bit_vector_total_size,
4433 &gc_count_bit_vector_storage);
4435 /* Free all unmarked compiled-function objects */
4436 sweep_compiled_functions();
4439 /* Put all unmarked floats on free list */
4441 #endif /* HAVE_FPFLOAT */
4443 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
4444 /* Put all unmarked bignums on free list */
4446 #endif /* HAVE_MPZ */
4448 #if defined HAVE_MPQ && defined WITH_GMP
4449 /* Put all unmarked ratios on free list */
4451 #endif /* HAVE_MPQ */
4453 #if defined HAVE_MPF && defined WITH_GMP
4454 /* Put all unmarked bigfloats on free list */
4456 #endif /* HAVE_MPF */
4458 #if defined HAVE_MPFR && defined WITH_MPFR
4459 /* Put all unmarked bigfloats on free list */
4461 #endif /* HAVE_MPFR */
4463 #if defined HAVE_PSEUG && defined WITH_PSEUG
4464 /* Put all unmarked gaussian numbers on free list */
4466 #endif /* HAVE_PSEUG */
4468 #if defined HAVE_MPC && defined WITH_MPC || \
4469 defined HAVE_PSEUC && defined WITH_PSEUC
4470 /* Put all unmarked complex numbers on free list */
4472 #endif /* HAVE_MPC */
4474 #if defined HAVE_QUATERN && defined WITH_QUATERN
4475 /* Put all unmarked quaternions on free list */
4477 #endif /* HAVE_QUATERN */
4479 /* Put all unmarked dynacats on free list */
4482 /* Put all unmarked symbols on free list */
4485 /* Put all unmarked extents on free list */
4488 /* Put all unmarked markers on free list.
4489 Dechain each one first from the buffer into which it points. */
4495 pdump_objects_unmark();
4500 /* Clearing for disksave. */
4502 void disksave_object_finalization(void)
4504 /* It's important that certain information from the environment not get
4505 dumped with the executable (pathnames, environment variables, etc.).
4506 To make it easier to tell when this has happened with strings(1) we
4507 clear some known-to-be-garbage blocks of memory, so that leftover
4508 results of old evaluation don't look like potential problems.
4509 But first we set some notable variables to nil and do one more GC,
4510 to turn those strings into garbage.
4513 /* Yeah, this list is pretty ad-hoc... */
4514 Vprocess_environment = Qnil;
4515 /* Vexec_directory = Qnil; */
4516 Vdata_directory = Qnil;
4517 Vdoc_directory = Qnil;
4518 Vconfigure_info_directory = Qnil;
4521 /* Vdump_load_path = Qnil; */
4522 /* Release hash tables for locate_file */
4523 Flocate_file_clear_hashing(Qt);
4524 uncache_home_directory();
4526 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
4527 defined(LOADHIST_BUILTIN))
4528 Vload_history = Qnil;
4530 Vshell_file_name = Qnil;
4532 garbage_collect_1();
4534 /* Run the disksave finalization methods of all live objects. */
4535 disksave_object_finalization_1();
4537 /* Zero out the uninitialized (really, unused) part of the containers
4538 for the live strings. */
4539 /* dont know what its counterpart in bdwgc mode is, so leave it out */
4540 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4542 struct string_chars_block *scb;
4543 for (scb = first_string_chars_block; scb; scb = scb->next) {
4544 int count = sizeof(scb->string_chars) - scb->pos;
4546 assert(count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
4548 /* from the block's fill ptr to the end */
4549 memset((scb->string_chars + scb->pos), 0,
4556 /* There, that ought to be enough... */
4560 Lisp_Object restore_gc_inhibit(Lisp_Object val)
4562 gc_currently_forbidden = XINT(val);
4566 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
4567 static int gc_hooks_inhibited;
4569 struct post_gc_action {
4570 void (*fun) (void *);
4574 typedef struct post_gc_action post_gc_action;
4577 Dynarr_declare(post_gc_action);
4578 } post_gc_action_dynarr;
4580 static post_gc_action_dynarr *post_gc_actions;
4582 /* Register an action to be called at the end of GC.
4583 gc_in_progress is 0 when this is called.
4584 This is used when it is discovered that an action needs to be taken,
4585 but it's during GC, so it's not safe. (e.g. in a finalize method.)
4587 As a general rule, do not use Lisp objects here.
4588 And NEVER signal an error.
4591 void register_post_gc_action(void (*fun) (void *), void *arg)
4593 post_gc_action action;
4595 if (!post_gc_actions)
4596 post_gc_actions = Dynarr_new(post_gc_action);
4601 Dynarr_add(post_gc_actions, action);
4604 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
4605 static void run_post_gc_actions(void)
4609 if (post_gc_actions) {
4610 for (i = 0; i < Dynarr_length(post_gc_actions); i++) {
4611 post_gc_action action = Dynarr_at(post_gc_actions, i);
4612 (action.fun) (action.arg);
4615 Dynarr_reset(post_gc_actions);
4621 mark_gcprolist(struct gcpro *gcpl)
4625 for (tail = gcpl; tail; tail = tail->next) {
4626 for (i = 0; i < tail->nvars; i++) {
4627 mark_object(tail->var[i]);
4633 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4642 void garbage_collect_1(void)
4644 SXE_DEBUG_GC("GC\n");
4645 #if defined GC_DEBUG_FLAG
4647 #endif /* GC_DEBUG_FLAG */
4649 GC_collect_a_little();
4653 GC_try_to_collect(stop_gc_p);
4659 void garbage_collect_1(void)
4661 #if MAX_SAVE_STACK > 0
4662 char stack_top_variable;
4663 extern char *stack_bottom;
4668 Lisp_Object pre_gc_cursor;
4669 struct gcpro gcpro1;
4672 || gc_currently_forbidden || in_display || preparing_for_armageddon)
4675 /* We used to call selected_frame() here.
4677 The following functions cannot be called inside GC
4678 so we move to after the above tests. */
4681 Lisp_Object device = Fselected_device(Qnil);
4682 /* Could happen during startup, eg. if always_gc */
4686 frame = DEVICE_SELECTED_FRAME(XDEVICE(device));
4688 signal_simple_error("No frames exist on device",
4694 pre_gc_cursor = Qnil;
4697 GCPRO1(pre_gc_cursor);
4699 /* Very important to prevent GC during any of the following
4700 stuff that might run Lisp code; otherwise, we'll likely
4701 have infinite GC recursion. */
4702 speccount = specpdl_depth();
4703 record_unwind_protect(restore_gc_inhibit,
4704 make_int(gc_currently_forbidden));
4705 gc_currently_forbidden = 1;
4707 if (!gc_hooks_inhibited)
4708 run_hook_trapping_errors("Error in pre-gc-hook", Qpre_gc_hook);
4710 /* Now show the GC cursor/message. */
4711 if (!noninteractive) {
4712 if (FRAME_WIN_P(f)) {
4713 Lisp_Object frame = make_frame(f);
4714 Lisp_Object cursor =
4715 glyph_image_instance(Vgc_pointer_glyph,
4716 FRAME_SELECTED_WINDOW(f),
4718 pre_gc_cursor = f->pointer;
4719 if (POINTER_IMAGE_INSTANCEP(cursor)
4720 /* don't change if we don't know how to change
4722 && POINTER_IMAGE_INSTANCEP(pre_gc_cursor)) {
4724 Fset_frame_pointer(frame, cursor);
4728 /* Don't print messages to the stream device. */
4729 if (STRINGP(Vgc_message) &&
4731 !FRAME_STREAM_P(f)) {
4732 char *msg = GETTEXT((char *) XSTRING_DATA(Vgc_message));
4733 Lisp_Object args[2], whole_msg;
4735 args[0] = build_string(
4736 msg ? msg : GETTEXT((char*)gc_default_message));
4737 args[1] = build_string("...");
4738 whole_msg = Fconcat(2, args);
4739 echo_area_message(f, (Bufbyte *) 0, whole_msg, 0, -1,
4740 Qgarbage_collecting);
4744 /***** Now we actually start the garbage collection. */
4748 inhibit_non_essential_printing_operations = 1;
4750 gc_generation_number[0]++;
4752 #if MAX_SAVE_STACK > 0
4754 /* Save a copy of the contents of the stack, for debugging. */
4756 /* Static buffer in which we save a copy of the C stack at each
4758 static char *stack_copy;
4759 static size_t stack_copy_size;
4761 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
4762 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
4763 if (stack_size < MAX_SAVE_STACK) {
4764 if (stack_copy_size < stack_size) {
4766 (char *)xrealloc(stack_copy, stack_size);
4767 stack_copy_size = stack_size;
4772 0 ? stack_bottom : &stack_top_variable,
4776 #endif /* MAX_SAVE_STACK > 0 */
4778 /* Do some totally ad-hoc resource clearing. */
4779 /* #### generalize this? */
4780 clear_event_resource();
4781 cleanup_specifiers();
4783 /* Mark all the special slots that serve as the roots of
4787 Lisp_Object **p = Dynarr_begin(staticpros);
4789 for (count = Dynarr_length(staticpros); count; count--) {
4794 { /* staticpro_nodump() */
4795 Lisp_Object **p = Dynarr_begin(staticpros_nodump);
4797 for (count = Dynarr_length(staticpros_nodump); count; count--) {
4802 #if defined(EF_USE_ASYNEQ)
4803 WITH_DLLIST_TRAVERSE(
4805 eq_worker_t eqw = dllist_item;
4806 struct gcpro *gcpl = eqw->gcprolist;
4807 mark_gcprolist(gcpl));
4810 mark_gcprolist(gcprolist);
4813 struct specbinding *bind;
4814 for (bind = specpdl; bind != specpdl_ptr; bind++) {
4815 mark_object(bind->symbol);
4816 mark_object(bind->old_value);
4821 struct catchtag *catch;
4822 for (catch = catchlist; catch; catch = catch->next) {
4823 mark_object(catch->tag);
4824 mark_object(catch->val);
4829 struct backtrace *backlist;
4830 for (backlist = backtrace_list; backlist;
4831 backlist = backlist->next) {
4832 int nargs = backlist->nargs;
4835 mark_object(*backlist->function);
4837 0 /* nargs == UNEVALLED || nargs == MANY */ )
4838 mark_object(backlist->args[0]);
4840 for (i = 0; i < nargs; i++)
4841 mark_object(backlist->args[i]);
4846 mark_profiling_info();
4848 /* OK, now do the after-mark stuff. This is for things that are only
4849 marked when something else is marked (e.g. weak hash tables). There
4850 may be complex dependencies between such objects -- e.g. a weak hash
4851 table might be unmarked, but after processing a later weak hash
4852 table, the former one might get marked. So we have to iterate until
4853 nothing more gets marked. */
4854 while (finish_marking_weak_hash_tables() > 0 ||
4855 finish_marking_weak_lists() > 0) ;
4857 /* And prune (this needs to be called after everything else has been
4858 marked and before we do any sweeping). */
4859 /* #### this is somewhat ad-hoc and should probably be an object
4861 prune_weak_hash_tables();
4864 prune_syntax_tables();
4868 consing_since_gc = 0;
4869 #ifndef DEBUG_SXEMACS
4870 /* Allow you to set it really fucking low if you really want ... */
4871 if (gc_cons_threshold < 10000)
4872 gc_cons_threshold = 10000;
4876 inhibit_non_essential_printing_operations = 0;
4879 run_post_gc_actions();
4881 /******* End of garbage collection ********/
4883 run_hook_trapping_errors("Error in post-gc-hook", Qpost_gc_hook);
4885 /* Now remove the GC cursor/message */
4886 if (!noninteractive) {
4888 Fset_frame_pointer(make_frame(f), pre_gc_cursor);
4889 else if (STRINGP(Vgc_message) && !FRAME_STREAM_P(f)) {
4890 char *msg = GETTEXT((char *)XSTRING_DATA(Vgc_message));
4892 /* Show "...done" only if the echo area would otherwise
4894 if (NILP(clear_echo_area(selected_frame(),
4895 Qgarbage_collecting, 0))) {
4896 Lisp_Object args[2], whole_msg;
4897 args[0] = build_string(
4899 : GETTEXT((char*)gc_default_message));
4900 args[1] = build_string("... done");
4901 whole_msg = Fconcat(2, args);
4902 echo_area_message(selected_frame(),
4903 (Bufbyte *) 0, whole_msg, 0,
4904 -1, Qgarbage_collecting);
4909 /* now stop inhibiting GC */
4910 unbind_to(speccount, Qnil);
4912 if (!breathing_space) {
4913 breathing_space = malloc(0xFFFF - MALLOC_OVERHEAD);
4922 /* Debugging aids. */
4923 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4924 #define HACK_O_MATIC(args...)
4925 #define gc_plist_hack(name, val, tail) \
4926 cons3(intern(name), Qzero, tail)
4930 static Lisp_Object gc_plist_hack(const char *name, int value, Lisp_Object tail)
4932 /* C doesn't have local functions (or closures, or GC, or readable
4933 syntax, or portable numeric datatypes, or bit-vectors, or characters,
4934 or arrays, or exceptions, or ...) */
4935 return cons3(intern(name), make_int(value), tail);
4938 #define HACK_O_MATIC(type, name, pl) \
4941 struct type##_block *x = current_##type##_block; \
4943 s += sizeof (*x) + MALLOC_OVERHEAD; \
4946 (pl) = gc_plist_hack ((name), s, (pl)); \
4950 DEFUN("garbage-collect", Fgarbage_collect, 0, 0, "", /*
4951 Reclaim storage for Lisp objects no longer needed.
4952 Return info on amount of space in use:
4953 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4954 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4956 where `PLIST' is a list of alternating keyword/value pairs providing
4957 more detailed information.
4958 Garbage collection happens automatically if you cons more than
4959 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4963 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
4967 Lisp_Object pl = Qnil;
4969 int gc_count_vector_total_size = 0;
4971 garbage_collect_1();
4973 for (i = 0; i < lrecord_type_count; i++) {
4974 if (lcrecord_stats[i].bytes_in_use != 0
4975 || lcrecord_stats[i].bytes_freed != 0
4976 || lcrecord_stats[i].instances_on_free_list != 0) {
4979 lrecord_implementations_table[i]->name;
4980 int len = strlen(name);
4983 /* save this for the FSFmacs-compatible part of the
4985 if (i == lrecord_type_vector)
4986 gc_count_vector_total_size =
4987 lcrecord_stats[i].bytes_in_use +
4988 lcrecord_stats[i].bytes_freed;
4990 sz = snprintf(buf, sizeof(buf), "%s-storage", name);
4991 assert(sz >=0 && (size_t)sz < sizeof(buf));
4992 pl = gc_plist_hack(buf, lcrecord_stats[i].bytes_in_use,
4994 /* Okay, simple pluralization check for
4995 `symbol-value-varalias' */
4996 if (name[len - 1] == 's')
4997 sz = snprintf(buf, sizeof(buf), "%ses-freed", name);
4999 sz = snprintf(buf, sizeof(buf), "%ss-freed", name);
5000 assert(sz >=0 && (size_t)sz < sizeof(buf));
5001 if (lcrecord_stats[i].instances_freed != 0)
5002 pl = gc_plist_hack(buf,
5004 instances_freed, pl);
5005 if (name[len - 1] == 's')
5006 sz = snprintf(buf, sizeof(buf), "%ses-on-free-list", name);
5008 sz = snprintf(buf, sizeof(buf), "%ss-on-free-list", name);
5009 assert(sz >=0 && (size_t)sz < sizeof(buf));
5010 if (lcrecord_stats[i].instances_on_free_list != 0)
5011 pl = gc_plist_hack(buf,
5013 instances_on_free_list, pl);
5014 if (name[len - 1] == 's')
5015 sz = snprintf(buf, sizeof(buf), "%ses-used", name);
5017 sz = snprintf(buf, sizeof(buf), "%ss-used", name);
5018 assert(sz >=0 && (size_t)sz < sizeof(buf));
5019 pl = gc_plist_hack(buf,
5020 lcrecord_stats[i].instances_in_use,
5025 HACK_O_MATIC(extent, "extent-storage", pl);
5026 pl = gc_plist_hack("extents-free", gc_count_num_extent_freelist, pl);
5027 pl = gc_plist_hack("extents-used", gc_count_num_extent_in_use, pl);
5028 HACK_O_MATIC(event, "event-storage", pl);
5029 pl = gc_plist_hack("events-free", gc_count_num_event_freelist, pl);
5030 pl = gc_plist_hack("events-used", gc_count_num_event_in_use, pl);
5031 HACK_O_MATIC(marker, "marker-storage", pl);
5032 pl = gc_plist_hack("markers-free", gc_count_num_marker_freelist, pl);
5033 pl = gc_plist_hack("markers-used", gc_count_num_marker_in_use, pl);
5035 HACK_O_MATIC(float, "float-storage", pl);
5036 pl = gc_plist_hack("floats-free", gc_count_num_float_freelist, pl);
5037 pl = gc_plist_hack("floats-used", gc_count_num_float_in_use, pl);
5038 #endif /* HAVE_FPFLOAT */
5039 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
5040 HACK_O_MATIC(bigz, "bigz-storage", pl);
5041 pl = gc_plist_hack("bigzs-free", gc_count_num_bigz_freelist, pl);
5042 pl = gc_plist_hack("bigzs-used", gc_count_num_bigz_in_use, pl);
5043 #endif /* HAVE_MPZ */
5044 #if defined HAVE_MPQ && defined WITH_GMP
5045 HACK_O_MATIC(bigq, "bigq-storage", pl);
5046 pl = gc_plist_hack("bigqs-free", gc_count_num_bigq_freelist, pl);
5047 pl = gc_plist_hack("bigqs-used", gc_count_num_bigq_in_use, pl);
5048 #endif /* HAVE_MPQ */
5049 #if defined HAVE_MPF && defined WITH_GMP
5050 HACK_O_MATIC(bigf, "bigf-storage", pl);
5051 pl = gc_plist_hack("bigfs-free", gc_count_num_bigf_freelist, pl);
5052 pl = gc_plist_hack("bigfs-used", gc_count_num_bigf_in_use, pl);
5053 #endif /* HAVE_MPF */
5054 #if defined HAVE_MPFR && defined WITH_MPFR
5055 HACK_O_MATIC(bigfr, "bigfr-storage", pl);
5056 pl = gc_plist_hack("bigfrs-free", gc_count_num_bigfr_freelist, pl);
5057 pl = gc_plist_hack("bigfrs-used", gc_count_num_bigfr_in_use, pl);
5058 #endif /* HAVE_MPFR */
5059 #if defined HAVE_PSEUG && defined WITH_PSEUG
5060 HACK_O_MATIC(bigg, "bigg-storage", pl);
5061 pl = gc_plist_hack("biggs-free", gc_count_num_bigg_freelist, pl);
5062 pl = gc_plist_hack("biggs-used", gc_count_num_bigg_in_use, pl);
5063 #endif /* HAVE_PSEUG */
5064 #if defined HAVE_MPC && defined WITH_MPC || \
5065 defined HAVE_PSEUC && defined WITH_PSEUC
5066 HACK_O_MATIC(bigc, "bigc-storage", pl);
5067 pl = gc_plist_hack("bigcs-free", gc_count_num_bigc_freelist, pl);
5068 pl = gc_plist_hack("bigcs-used", gc_count_num_bigc_in_use, pl);
5069 #endif /* HAVE_MPC */
5070 #if defined HAVE_QUATERN && defined WITH_QUATERN
5071 HACK_O_MATIC(quatern, "quatern-storage", pl);
5072 pl = gc_plist_hack("quaterns-free", gc_count_num_quatern_freelist, pl);
5073 pl = gc_plist_hack("quaterns-used", gc_count_num_quatern_in_use, pl);
5074 #endif /* HAVE_QUATERN */
5076 HACK_O_MATIC(dynacat, "dynacat-storage", pl);
5077 pl = gc_plist_hack("dynacats-free", gc_count_num_dynacat_freelist, pl);
5078 pl = gc_plist_hack("dynacats-used", gc_count_num_dynacat_in_use, pl);
5080 HACK_O_MATIC(string, "string-header-storage", pl);
5081 pl = gc_plist_hack("long-strings-total-length",
5082 gc_count_string_total_size
5083 - gc_count_short_string_total_size, pl);
5084 HACK_O_MATIC(string_chars, "short-string-storage", pl);
5085 pl = gc_plist_hack("short-strings-total-length",
5086 gc_count_short_string_total_size, pl);
5087 pl = gc_plist_hack("strings-free", gc_count_num_string_freelist, pl);
5088 pl = gc_plist_hack("long-strings-used",
5089 gc_count_num_string_in_use
5090 - gc_count_num_short_string_in_use, pl);
5091 pl = gc_plist_hack("short-strings-used",
5092 gc_count_num_short_string_in_use, pl);
5094 HACK_O_MATIC(compiled_function, "compiled-function-storage", pl);
5095 pl = gc_plist_hack("compiled-functions-free",
5096 gc_count_num_compiled_function_freelist, pl);
5097 pl = gc_plist_hack("compiled-functions-used",
5098 gc_count_num_compiled_function_in_use, pl);
5100 pl = gc_plist_hack("bit-vector-storage", gc_count_bit_vector_storage,
5102 pl = gc_plist_hack("bit-vectors-total-length",
5103 gc_count_bit_vector_total_size, pl);
5104 pl = gc_plist_hack("bit-vectors-used", gc_count_num_bit_vector_used,
5107 HACK_O_MATIC(symbol, "symbol-storage", pl);
5108 pl = gc_plist_hack("symbols-free", gc_count_num_symbol_freelist, pl);
5109 pl = gc_plist_hack("symbols-used", gc_count_num_symbol_in_use, pl);
5111 HACK_O_MATIC(cons, "cons-storage", pl);
5112 pl = gc_plist_hack("conses-free", gc_count_num_cons_freelist, pl);
5113 pl = gc_plist_hack("conses-used", gc_count_num_cons_in_use, pl);
5115 /* The things we do for backwards-compatibility */
5116 /* fuck, what are we doing about those in the bdwgc era? -hrop */
5118 list6(Fcons(make_int(gc_count_num_cons_in_use),
5119 make_int(gc_count_num_cons_freelist)),
5120 Fcons(make_int(gc_count_num_symbol_in_use),
5121 make_int(gc_count_num_symbol_freelist)),
5122 Fcons(make_int(gc_count_num_marker_in_use),
5123 make_int(gc_count_num_marker_freelist)),
5124 make_int(gc_count_string_total_size),
5125 make_int(gc_count_vector_total_size), pl);
5131 /* grrrr ... lisp/itimer-autosave.el is using this, WTF? */
5132 DEFUN("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
5133 Return the number of bytes consed since the last garbage collection.
5134 \"Consed\" is a misnomer in that this actually counts allocation
5135 of all different kinds of objects, not just conses.
5137 If this value exceeds `gc-cons-threshold', a garbage collection happens.
5141 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
5144 return make_int(consing_since_gc);
5149 int object_dead_p(Lisp_Object obj)
5151 return ((BUFFERP(obj) && !BUFFER_LIVE_P(XBUFFER(obj))) ||
5152 (FRAMEP(obj) && !FRAME_LIVE_P(XFRAME(obj))) ||
5153 (WINDOWP(obj) && !WINDOW_LIVE_P(XWINDOW(obj))) ||
5154 (DEVICEP(obj) && !DEVICE_LIVE_P(XDEVICE(obj))) ||
5155 (CONSOLEP(obj) && !CONSOLE_LIVE_P(XCONSOLE(obj))) ||
5156 (EVENTP(obj) && !EVENT_LIVE_P(XEVENT(obj))) ||
5157 (EXTENTP(obj) && !EXTENT_LIVE_P(XEXTENT(obj))));
5160 #if defined MEMORY_USAGE_STATS && !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5162 /* Attempt to determine the actual amount of space that is used for
5163 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
5165 It seems that the following holds:
5167 1. When using the old allocator (malloc.c):
5169 -- blocks are always allocated in chunks of powers of two. For
5170 each block, there is an overhead of 8 bytes if rcheck is not
5171 defined, 20 bytes if it is defined. In other words, a
5172 one-byte allocation needs 8 bytes of overhead for a total of
5173 9 bytes, and needs to have 16 bytes of memory chunked out for
5176 2. When using the new allocator (gmalloc.c):
5178 -- blocks are always allocated in chunks of powers of two up
5179 to 4096 bytes. Larger blocks are allocated in chunks of
5180 an integral multiple of 4096 bytes. The minimum block
5181 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
5182 is defined. There is no per-block overhead, but there
5183 is an overhead of 3*sizeof (size_t) for each 4096 bytes
5186 3. When using the system malloc, anything goes, but they are
5187 generally slower and more space-efficient than the GNU
5188 allocators. One possibly reasonable assumption to make
5189 for want of better data is that sizeof (void *), or maybe
5190 2 * sizeof (void *), is required as overhead and that
5191 blocks are allocated in the minimum required size except
5192 that some minimum block size is imposed (e.g. 16 bytes). */
5195 malloced_storage_size(void *ptr, size_t claimed_size,
5196 struct overhead_stats * stats)
5198 size_t orig_claimed_size = claimed_size;
5202 if (claimed_size < 2 * sizeof(void *))
5203 claimed_size = 2 * sizeof(void *);
5204 # ifdef SUNOS_LOCALTIME_BUG
5205 if (claimed_size < 16)
5208 if (claimed_size < 4096) {
5211 /* compute the log base two, more or less, then use it to compute
5212 the block size needed. */
5214 /* It's big, it's heavy, it's wood! */
5215 while ((claimed_size /= 2) != 0)
5218 /* It's better than bad, it's good! */
5223 /* We have to come up with some average about the amount of
5225 if ((size_t) (rand() & 4095) < claimed_size)
5226 claimed_size += 3 * sizeof(void *);
5228 claimed_size += 4095;
5229 claimed_size &= ~4095;
5230 claimed_size += (claimed_size / 4096) * 3 * sizeof(size_t);
5233 #elif defined (SYSTEM_MALLOC)
5235 if (claimed_size < 16)
5237 claimed_size += 2 * sizeof(void *);
5239 #else /* old GNU allocator */
5241 # ifdef rcheck /* #### may not be defined here */
5249 /* compute the log base two, more or less, then use it to compute
5250 the block size needed. */
5252 /* It's big, it's heavy, it's wood! */
5253 while ((claimed_size /= 2) != 0)
5256 /* It's better than bad, it's good! */
5263 #endif /* old GNU allocator */
5266 stats->was_requested += orig_claimed_size;
5267 stats->malloc_overhead += claimed_size - orig_claimed_size;
5269 return claimed_size;
5272 size_t fixed_type_block_overhead(size_t size)
5274 size_t per_block = TYPE_ALLOC_SIZE(cons, unsigned char);
5275 size_t overhead = 0;
5276 size_t storage_size = malloced_storage_size(0, per_block, 0);
5277 while (size >= per_block) {
5279 overhead += sizeof(void *) + per_block - storage_size;
5281 if (rand() % per_block < size)
5282 overhead += sizeof(void *) + per_block - storage_size;
5286 #endif /* MEMORY_USAGE_STATS */
5288 #ifdef EF_USE_ASYNEQ
5290 init_main_worker(void)
5292 eq_worker_t res = eq_make_worker();
5293 eq_worker_thread(res) = pthread_self();
5298 #if defined HAVE_MPZ && defined WITH_GMP || \
5299 defined HAVE_MPFR && defined WITH_MPFR
5301 my_malloc(size_t bar)
5303 /* we use atomic here since GMP/MPFR do supervise their objects */
5304 void *foo = xmalloc(bar);
5305 SXE_DEBUG_GC_GMP("alloc :is %p :size %lu\n",
5306 foo, (long unsigned int)bar);
5310 /* We need the next two functions since GNU MP insists on giving us an extra
5313 my_realloc (void *ptr, size_t SXE_UNUSED(old_size), size_t new_size)
5315 void *foo = xrealloc(ptr, new_size);
5316 SXE_DEBUG_GC_GMP("gmp realloc :was %p :is %p\n", ptr, foo);
5321 my_free (void *ptr, size_t size)
5323 SXE_DEBUG_GC_GMP("free :was %p :size %lu\n",
5324 ptr, (long unsigned int)size);
5325 memset(ptr, 0, size);
5329 #endif /* GMP || MPFR */
5331 #if defined HAVE_BDWGC && defined EF_USE_BDWGC && !defined GC_DEBUG_FLAG
5333 my_shy_warn_proc(char *msg, GC_word arg)
5335 /* just don't do anything */
5341 /* Initialization */
5342 void init_bdwgc(void);
5347 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
5348 # if defined GC_DEBUG_FLAG
5349 extern long GC_large_alloc_warn_interval;
5351 GC_time_limit = GC_TIME_UNLIMITED;
5352 GC_use_entire_heap = 0;
5355 GC_all_interior_pointers = 1;
5359 GC_free_space_divisor = 8;
5361 #if !defined GC_DEBUG_FLAG
5362 GC_set_warn_proc(my_shy_warn_proc);
5363 #else /* GC_DEBUG_FLAG */
5364 GC_large_alloc_warn_interval = 1L;
5365 #endif /* GC_DEBUG_FLAG */
5372 __init_gmp_mem_funs(void)
5374 #if defined HAVE_MPZ && defined WITH_GMP || \
5375 defined HAVE_MPFR && defined WITH_MPFR
5376 mp_set_memory_functions(my_malloc, my_realloc, my_free);
5377 #endif /* GMP || MPFR */
5380 void reinit_alloc_once_early(void)
5382 gc_generation_number[0] = 0;
5383 breathing_space = NULL;
5384 XSETINT(all_bit_vectors, 0); /* Qzero may not be set yet. */
5385 XSETINT(Vgc_message, 0);
5386 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5389 ignore_malloc_warnings = 1;
5390 #ifdef DOUG_LEA_MALLOC
5391 mallopt(M_TRIM_THRESHOLD, 128 * 1024); /* trim threshold */
5392 mallopt(M_MMAP_THRESHOLD, 64 * 1024); /* mmap threshold */
5393 #if 1 /* Moved to emacs.c */
5394 mallopt(M_MMAP_MAX, 0); /* max. number of mmap'ed areas */
5397 /* the category subsystem */
5398 morphisms[lrecord_type_cons].seq_impl = &__scons;
5399 morphisms[lrecord_type_vector].seq_impl = &__svec;
5400 morphisms[lrecord_type_string].seq_impl = &__sstr;
5401 morphisms[lrecord_type_bit_vector].seq_impl = &__sbvc;
5403 init_string_alloc();
5404 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5405 init_string_chars_alloc();
5408 init_symbol_alloc();
5409 init_compiled_function_alloc();
5413 __init_gmp_mem_funs();
5414 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP) && \
5415 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5418 #if defined HAVE_MPQ && defined WITH_GMP && \
5419 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5422 #if defined HAVE_MPF && defined WITH_GMP && \
5423 !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5426 #if defined HAVE_MPFR && defined WITH_MPFR
5429 #if defined HAVE_PSEUG && defined HAVE_MPZ && defined WITH_PSEUG
5432 #if defined HAVE_MPC && defined WITH_MPC || \
5433 defined HAVE_PSEUC && defined WITH_PSEUC
5436 #if defined HAVE_QUATERN && defined HAVE_MPZ && defined WITH_QUATERN
5437 init_quatern_alloc();
5439 init_dynacat_alloc();
5441 init_marker_alloc();
5442 init_extent_alloc();
5445 ignore_malloc_warnings = 0;
5447 /* we only use the 500k value for now */
5448 gc_cons_threshold = 500000;
5449 lrecord_uid_counter = 259;
5451 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
5452 if (staticpros_nodump) {
5453 Dynarr_free(staticpros_nodump);
5455 staticpros_nodump = Dynarr_new2(Lisp_Object_ptr_dynarr, Lisp_Object *);
5456 /* merely a small optimization */
5457 Dynarr_resize(staticpros_nodump, 100);
5459 /* tuning the GCor */
5460 consing_since_gc = 0;
5461 debug_string_purity = 0;
5463 #ifdef EF_USE_ASYNEQ
5464 workers = make_noseeum_dllist();
5465 dllist_prepend(workers, init_main_worker());
5470 #if defined EF_USE_ASYNEQ && !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
5471 SXE_MUTEX_INIT(&cons_mutex);
5474 gc_currently_forbidden = 0;
5475 gc_hooks_inhibited = 0;
5477 #ifdef ERROR_CHECK_TYPECHECK
5479 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5482 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5485 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5487 #endif /* ERROR_CHECK_TYPECHECK */
5490 void init_alloc_once_early(void)
5492 reinit_alloc_once_early();
5494 for (int i = 0; i < countof(lrecord_implementations_table); i++) {
5495 lrecord_implementations_table[i] = 0;
5498 INIT_LRECORD_IMPLEMENTATION(cons);
5499 INIT_LRECORD_IMPLEMENTATION(vector);
5500 INIT_LRECORD_IMPLEMENTATION(string);
5501 INIT_LRECORD_IMPLEMENTATION(lcrecord_list);
5503 staticpros = Dynarr_new2(Lisp_Object_ptr_dynarr, Lisp_Object *);
5504 Dynarr_resize(staticpros, 1410); /* merely a small optimization */
5505 dump_add_root_struct_ptr(&staticpros, &staticpros_description);
5507 /* GMP/MPFR mem funs */
5508 __init_gmp_mem_funs();
5513 void reinit_alloc(void)
5515 #ifdef EF_USE_ASYNEQ
5516 eq_worker_t main_th;
5517 assert(dllist_size(workers) == 1);
5518 main_th = dllist_car(workers);
5519 eq_worker_gcprolist(main_th) = NULL;
5525 void syms_of_alloc(void)
5527 DEFSYMBOL(Qpre_gc_hook);
5528 DEFSYMBOL(Qpost_gc_hook);
5529 DEFSYMBOL(Qgarbage_collecting);
5534 DEFSUBR(Fbit_vector);
5535 DEFSUBR(Fmake_byte_code);
5536 DEFSUBR(Fmake_list);
5537 DEFSUBR(Fmake_vector);
5538 DEFSUBR(Fmake_bit_vector);
5539 DEFSUBR(Fmake_string);
5541 DEFSUBR(Fmake_symbol);
5542 DEFSUBR(Fmake_marker);
5544 DEFSUBR(Fgarbage_collect);
5545 DEFSUBR(Fconsing_since_gc);
5548 void vars_of_alloc(void)
5550 DEFVAR_INT("gc-cons-threshold", &gc_cons_threshold /*
5551 *Number of bytes of consing between garbage collections.
5552 \"Consing\" is a misnomer in that this actually counts allocation
5553 of all different kinds of objects, not just conses.
5554 Garbage collection can happen automatically once this many bytes have been
5555 allocated since the last garbage collection. All data types count.
5557 Garbage collection happens automatically when `eval' or `funcall' are
5558 called. (Note that `funcall' is called implicitly as part of evaluation.)
5559 By binding this temporarily to a large number, you can effectively
5560 prevent garbage collection during a part of the program.
5562 See also `consing-since-gc'.
5565 #ifdef DEBUG_SXEMACS
5566 DEFVAR_INT("debug-allocation", &debug_allocation /*
5567 If non-zero, print out information to stderr about all objects allocated.
5568 See also `debug-allocation-backtrace-length'.
5570 debug_allocation = 0;
5572 DEFVAR_INT("debug-allocation-backtrace-length", &debug_allocation_backtrace_length /*
5573 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
5575 debug_allocation_backtrace_length = 2;
5578 DEFVAR_BOOL("purify-flag", &purify_flag /*
5579 Non-nil means loading Lisp code in order to dump an executable.
5580 This means that certain objects should be allocated in readonly space.
5583 DEFVAR_LISP("pre-gc-hook", &Vpre_gc_hook /*
5584 Function or functions to be run just before each garbage collection.
5585 Interrupts, garbage collection, and errors are inhibited while this hook
5586 runs, so be extremely careful in what you add here. In particular, avoid
5587 consing, and do not interact with the user.
5589 Vpre_gc_hook = Qnil;
5591 DEFVAR_LISP("post-gc-hook", &Vpost_gc_hook /*
5592 Function or functions to be run just after each garbage collection.
5593 Interrupts, garbage collection, and errors are inhibited while this hook
5594 runs, so be extremely careful in what you add here. In particular, avoid
5595 consing, and do not interact with the user.
5597 Vpost_gc_hook = Qnil;
5599 DEFVAR_LISP("gc-message", &Vgc_message /*
5600 String to print to indicate that a garbage collection is in progress.
5601 This is printed in the echo area. If the selected frame is on a
5602 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
5603 image instance) in the domain of the selected frame, the mouse pointer
5604 will change instead of this message being printed.
5605 If it has non-string value - nothing is printed.
5607 Vgc_message = build_string(gc_default_message);
5609 DEFVAR_LISP("gc-pointer-glyph", &Vgc_pointer_glyph /*
5610 Pointer glyph used to indicate that a garbage collection is in progress.
5611 If the selected window is on a window system and this glyph specifies a
5612 value (i.e. a pointer image instance) in the domain of the selected
5613 window, the pointer will be changed as specified during garbage collection.
5614 Otherwise, a message will be printed in the echo area, as controlled
5619 void complex_vars_of_alloc(void)
5621 Vgc_pointer_glyph = Fmake_glyph_internal(Qpointer);