git.chise.org Git - chise/xemacs-chise.git.1/blob - src/opaque.c

   1 /* Opaque Lisp objects.
   2    Copyright (C) 1993, 1994, 1995 Sun Microsystems, Inc.
   3    Copyright (C) 1995, 1996 Ben Wing.
   4
   5 This file is part of XEmacs.
   6
   7 XEmacs is free software; you can redistribute it and/or modify it
   8 under the terms of the GNU General Public License as published by the
   9 Free Software Foundation; either version 2, or (at your option) any
  10 later version.
  11
  12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with XEmacs; see the file COPYING.  If not, write to
  19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 Boston, MA 02111-1307, USA.  */
  21
  22 /* Synched up with: Not in FSF. */
  23
  24 /* Written by Ben Wing, October 1993. */
  25
  26 /* "Opaque" is used internally to hold keep track of allocated memory
  27    so it gets GC'd properly, and to store arbitrary data in places
  28    where a Lisp_Object is required and which may get GC'd. (e.g.  as
  29    the argument to record_unwind_protect()).  Once created in C,
  30    opaque objects cannot be resized.
  31
  32    OPAQUE OBJECTS SHOULD NEVER ESCAPE TO THE LISP LEVEL.  Some code
  33    depends on this.  As such, opaque objects are a generalization
  34    of the Qunbound marker.
  35
  36    "Opaque lists" are used to keep track of lots of opaque objects
  37    of a particular size so that they can be efficiently "freed" and
  38    re-used again without actually entering the Lisp allocation system
  39    (and consequently doing a malloc()).
  40  */
  41
  42 #include <config.h>
  43 #include "lisp.h"
  44 #include "opaque.h"
  45 #include <stddef.h>
  46
  47 Lisp_Object Qopaquep;
  48
  49 static int in_opaque_list_marking;
  50
  51 /* Holds freed opaque objects created with make_opaque_ptr().
  52    We do this quite often so it's a noticeable win if we don't
  53    create GC junk. */
  54 Lisp_Object Vopaque_ptr_free_list;
  55
  56 static Lisp_Object
  57 mark_opaque (Lisp_Object obj, void (*markobj) (Lisp_Object))
  58 {
  59    Lisp_Opaque *p = XOPAQUE (obj);
  60    Lisp_Object size_or_chain = p->size_or_chain;
  61 #ifdef ERROR_CHECK_GC
  62   if (!in_opaque_list_marking)
  63     /* size is non-int for objects on an opaque free list.  We sure
  64        as hell better not be marking any of these objects unless
  65        we're marking an opaque list. */
  66     assert (GC_INTP (size_or_chain));
  67   else
  68     /* marking an opaque on the free list doesn't do any recursive
  69        markings, so we better not have non-freed opaques on a free
  70        list. */
  71     assert (!GC_INTP (size_or_chain));
  72 #endif
  73   if (GC_INTP (size_or_chain) && OPAQUE_MARKFUN (p))
  74     return OPAQUE_MARKFUN (p) (obj, markobj);
  75   else
  76     return size_or_chain;
  77 }
  78
  79 /* Should never, ever be called. (except by an external debugger) */
  80 static void
  81 print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
  82 {
  83   CONST Lisp_Opaque *p = XOPAQUE (obj);
  84   char buf[200];
  85   char size_buf[50];
  86
  87   if (INTP (p->size_or_chain))
  88     sprintf (size_buf, "size=%lu", (unsigned long) OPAQUE_SIZE (p));
  89   else
  90     sprintf (size_buf, "freed");
  91
  92   sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (opaque, %s) 0x%lx>",
  93            size_buf, (unsigned long) p);
  94   write_c_string (buf, printcharfun);
  95 }
  96
  97 static size_t
  98 sizeof_opaque (CONST void *header)
  99 {
 100   CONST Lisp_Opaque *p = (CONST Lisp_Opaque *) header;
 101   return offsetof (Lisp_Opaque, data)
 102     + (GC_INTP (p->size_or_chain) ? XINT (p->size_or_chain) : 0);
 103 }
 104
 105 /* Return an opaque object of size SIZE.
 106    If DATA is OPAQUE_CLEAR, the object's data is memset to '\0' bytes.
 107    If DATA is OPAQUE_UNINIT, the object's data is uninitialized.
 108    Else the object's data is initialized by copying from DATA. */
 109 Lisp_Object
 110 make_opaque (size_t size, CONST void *data)
 111 {
 112   Lisp_Opaque *p = (Lisp_Opaque *)
 113     alloc_lcrecord (offsetof (Lisp_Opaque, data) + size, lrecord_opaque);
 114   p->markfun = 0;
 115   p->size_or_chain = make_int (size);
 116
 117   if (data == OPAQUE_CLEAR)
 118     memset (p->data, '\0', size);
 119   else if (data == OPAQUE_UNINIT)
 120     DO_NOTHING;
 121   else
 122     memcpy (p->data, data, size);
 123
 124   {
 125     Lisp_Object val;
 126     XSETOPAQUE (val, p);
 127     return val;
 128   }
 129 }
 130
 131 /* This will not work correctly for opaques with subobjects! */
 132
 133 static int
 134 equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth)
 135 {
 136   size_t size;
 137 #ifdef DEBUG_XEMACS
 138   assert (!XOPAQUE_MARKFUN (obj1) && !XOPAQUE_MARKFUN (obj2));
 139   assert (INTP (XOPAQUE (obj1)->size_or_chain));
 140   assert (INTP (XOPAQUE (obj2)->size_or_chain));
 141 #endif
 142   return ((size = XOPAQUE_SIZE (obj1)) == XOPAQUE_SIZE (obj2) &&
 143           !memcmp (XOPAQUE_DATA (obj1), XOPAQUE_DATA (obj2), size));
 144 }
 145
 146 /* This will not work correctly for opaques with subobjects! */
 147
 148 static unsigned long
 149 hash_opaque (Lisp_Object obj, int depth)
 150 {
 151 #ifdef DEBUG_XEMACS
 152   assert (!XOPAQUE_MARKFUN (obj));
 153   assert (INTP (XOPAQUE (obj)->size_or_chain));
 154 #endif
 155   if (XOPAQUE_SIZE (obj) == sizeof (unsigned long))
 156     return *((unsigned long *) XOPAQUE_DATA(obj));
 157   else
 158     return memory_hash (XOPAQUE_DATA (obj), XOPAQUE_SIZE (obj));
 159 }
 160
 161 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque,
 162                                         mark_opaque, print_opaque, 0,
 163                                         equal_opaque, hash_opaque,
 164                                         sizeof_opaque, Lisp_Opaque);
 165
 166 static Lisp_Object
 167 mark_opaque_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
 168 {
 169   in_opaque_list_marking++;
 170   markobj (XOPAQUE_LIST (obj)->free);
 171   in_opaque_list_marking--;
 172   return Qnil;
 173 }
 174
 175 Lisp_Object
 176 make_opaque_list (size_t size,
 177                   Lisp_Object (*markfun) (Lisp_Object obj,
 178                                           void (*markobj) (Lisp_Object)))
 179 {
 180   Lisp_Object val;
 181   Lisp_Opaque_List *p =
 182     alloc_lcrecord_type (Lisp_Opaque_List, lrecord_opaque_list);
 183
 184   p->markfun = markfun;
 185   p->size = size;
 186   p->free = Qnil;
 187   XSETOPAQUE_LIST (val, p);
 188   return val;
 189 }
 190
 191 DEFINE_LRECORD_IMPLEMENTATION ("opaque-list", opaque_list,
 192                                mark_opaque_list, internal_object_printer,
 193                                0, 0, 0, Lisp_Opaque_List);
 194
 195 Lisp_Object
 196 allocate_managed_opaque (Lisp_Object opaque_list, CONST void *data)
 197 {
 198   Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
 199   Lisp_Object val;
 200
 201   if (!NILP (li->free))
 202     {
 203       val = li->free;
 204       li->free = XOPAQUE (val)->size_or_chain;
 205 #ifdef ERROR_CHECK_GC
 206       assert (NILP (li->free) || OPAQUEP (li->free));
 207 #endif
 208       XOPAQUE (val)->size_or_chain = make_int (li->size);
 209       if (data)
 210         memcpy (XOPAQUE (val)->data, data, li->size);
 211       else
 212         memset (XOPAQUE (val)->data, 0, li->size);
 213     }
 214   else
 215     val = make_opaque (li->size, data);
 216   XOPAQUE (val)->markfun = li->markfun;
 217   return val;
 218 }
 219
 220 void
 221 free_managed_opaque (Lisp_Object opaque_list, Lisp_Object opaque)
 222 {
 223   Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list);
 224
 225 #ifdef ERROR_CHECK_GC
 226   assert (INTP (XOPAQUE (opaque)->size_or_chain));
 227 #endif
 228   XOPAQUE (opaque)->size_or_chain = li->free;
 229   li->free = opaque;
 230 }
 231
 232 /* stuff to handle opaque pointers */
 233
 234 Lisp_Object
 235 make_opaque_ptr (CONST void *val)
 236 {
 237   return allocate_managed_opaque (Vopaque_ptr_free_list,
 238                                   (CONST void *) &val);
 239 }
 240
 241 /* Be very very careful with this.  Same admonitions as with
 242    free_cons() apply. */
 243
 244 void
 245 free_opaque_ptr (Lisp_Object ptr)
 246 {
 247   free_managed_opaque (Vopaque_ptr_free_list, ptr);
 248 }
 249
 250 Lisp_Object
 251 make_opaque_long (long val)
 252 {
 253   return make_opaque (sizeof (val), (void *) &val);
 254 }
 255
 256 void
 257 init_opaque_once_early (void)
 258 {
 259   Vopaque_ptr_free_list = make_opaque_list (sizeof (void *), 0);
 260   staticpro (&Vopaque_ptr_free_list);
 261 }