cgit.sxemacs.org Git - sxemacs/blob - src/alloc.c

   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.
   5
   6 This file is part of SXEmacs
   7
   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.
  12
  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.
  17
  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/>. */
  20
  21
  22 /* Synched up with: FSF 19.28, Mule 2.0.  Substantially different from
  23    FSF. */
  24
  25 /* Authorship:
  26
  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)
  39 */
  40
  41 #include <config.h>
  42 #include "lisp.h"
  43
  44 #include "backtrace.h"
  45 #include "buffer.h"
  46 #include "bytecode.h"
  47 #include "chartab.h"
  48 #include "ui/device.h"
  49 #include "elhash.h"
  50 #define INCLUDE_EVENTS_H_PRIVATE_SPHERE
  51 #include "events/events.h"
  52 #include "extents.h"
  53 #include "ui/frame.h"
  54 #include "ui/glyphs.h"
  55 #include "opaque.h"
  56 #include "ui/redisplay.h"
  57 #include "specifier.h"
  58 #include "sysfile.h"
  59 #include "sysdep.h"
  60 #include "ui/window.h"
  61 #include "ui/console-stream.h"
  62
  63 #include <ent/ent.h>
  64 #include <ent/ent-float.h>
  65
  66 #ifdef DOUG_LEA_MALLOC
  67 #include <malloc.h>
  68 #endif
  69
  70 #ifdef PDUMP
  71 #include "dumper.h"
  72 #endif
  73
  74 #define SXE_DEBUG_GC_GMP(args...)       SXE_DEBUG_GC("[gmp]: " args)
  75
  76 /* bdwgc */
  77 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
  78 # undef GC_DEBUG
  79 # define GC_DEBUG       1
  80 # if defined HAVE_GC_GC_H
  81 #  include "gc/gc.h"
  82 # elif defined HAVE_GC_H
  83 #  include "gc.h"
  84 # elif 1
  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*);
  93 # else
  94 #  error "I'm very concerned about your BDWGC support"
  95 # endif
  96 #endif
  97
  98 /* category subsystem */
  99 #include "category.h"
 100 #include "dynacat.h"
 101 #include "seq.h"
 102 #include "dict.h"
 103
 104 EXFUN(Fgarbage_collect, 0);
 105
 106 #if 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
 110 #endif
 111 #endif
 112
 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 */
 117 #include <dmalloc.h>
 118 #define ALLOC_NO_POOLS
 119 #endif
 120
 121 #ifdef DEBUG_SXEMACS
 122 static Fixnum debug_allocation;
 123 static Fixnum debug_allocation_backtrace_length;
 124 #endif
 125
 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 */
 130 #ifdef EF_USE_ASYNEQ
 131 #include "events/event-queue.h"
 132 #include "events/workers.h"
 133 dllist_t workers = NULL;
 134 #endif
 135
 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)
 139
 140 #else  /* !BDWGC */
 141
 142 EMACS_INT consing_since_gc;
 143 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
 144 #endif  /* BDWGC */
 145
 146 #ifdef DEBUG_SXEMACS
 147 static inline void
 148 debug_allocation_backtrace(void)
 149 {
 150         if (debug_allocation_backtrace_length > 0) {
 151                 debug_short_backtrace (debug_allocation_backtrace_length);
 152         }
 153         return;
 154 }
 155
 156 #define INCREMENT_CONS_COUNTER(foosize, type)                           \
 157         do {                                                            \
 158                 if (debug_allocation) {                                 \
 159                         stderr_out("allocating %s (size %ld)\n",        \
 160                                    type, (long)foosize);                \
 161                         debug_allocation_backtrace ();                  \
 162                 }                                                       \
 163                 INCREMENT_CONS_COUNTER_1(foosize);                      \
 164         } while (0)
 165 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type)                   \
 166         do {                                                            \
 167                 if (debug_allocation > 1) {                             \
 168                         stderr_out("allocating noseeum %s (size %ld)\n", \
 169                                    type, (long)foosize);                \
 170                         debug_allocation_backtrace ();                  \
 171                 }                                                       \
 172                 INCREMENT_CONS_COUNTER_1(foosize);                      \
 173         } while (0)
 174 #else
 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)
 178 #endif
 179
 180 static inline void
 181 DECREMENT_CONS_COUNTER(size_t size)
 182         __attribute__((always_inline));
 183
 184 static inline void
 185 DECREMENT_CONS_COUNTER(size_t size)
 186 {
 187         consing_since_gc -= (size);
 188         if (consing_since_gc < 0) {
 189                 consing_since_gc = 0;
 190         }
 191 }
 192
 193 /* Number of bytes of consing since gc before another gc should be done. */
 194 EMACS_INT gc_cons_threshold;
 195
 196 /* Nonzero during gc */
 197 int gc_in_progress;
 198
 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];
 203
 204 /* This is just for use by the printer, to allow things to print uniquely */
 205 static int lrecord_uid_counter;
 206
 207 /* Nonzero when calling certain hooks or doing other things where
 208    a GC would be bad */
 209 int gc_currently_forbidden;
 210
 211 /* Hooks. */
 212 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
 213 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
 214
 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;
 220
 221 /* Non-zero means we're in the process of doing the dump */
 222 int purify_flag;
 223
 224 #ifdef ERROR_CHECK_TYPECHECK
 225
 226 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
 227
 228 #endif
 229
 230 int c_readonly(Lisp_Object obj)
 231 {
 232         return POINTER_TYPE_P(XTYPE(obj)) && C_READONLY(obj);
 233 }
 234
 235 int lisp_readonly(Lisp_Object obj)
 236 {
 237         return POINTER_TYPE_P(XTYPE(obj)) && LISP_READONLY(obj);
 238 }
 239 \f
 240 /* Maximum amount of C stack to save when a GC happens.  */
 241
 242 #ifndef MAX_SAVE_STACK
 243 #define MAX_SAVE_STACK 0        /* 16000 */
 244 #endif
 245
 246 /* Non-zero means ignore malloc warnings.  Set during initialization.  */
 247 int ignore_malloc_warnings;
 248 \f
 249 static void *breathing_space = NULL;
 250
 251 void release_breathing_space(void)
 252 {
 253         if (breathing_space) {
 254                 void *tmp = breathing_space;
 255                 breathing_space = NULL;
 256                 free(tmp);
 257         }
 258 }
 259
 260 /* malloc calls this if it finds we are near exhausting storage */
 261 void malloc_warning(const char *str)
 262 {
 263         if (ignore_malloc_warnings)
 264                 return;
 265
 266         warn_when_safe
 267             (Qmemory, Qcritical,
 268              "%s\n"
 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);
 272 }
 273
 274 /* Called if malloc returns zero */
 275 DOESNT_RETURN memory_full(void)
 276 {
 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"
 280          */
 281 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
 282         /* that's all we can do */
 283         GC_gcollect();
 284 #else  /* !BDWGC */
 285         consing_since_gc = gc_cons_threshold + 1;
 286         release_breathing_space();
 287 #endif  /* BDWGC */
 288
 289         /* Flush some histories which might conceivably contain garbalogical
 290            inhibitors.  */
 291         if (!NILP(Fboundp(Qvalues))) {
 292                 Fset(Qvalues, Qnil);