libguile/smob.c

   1 /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
   2  *   2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20
  21 \f
  22 #ifdef HAVE_CONFIG_H
  23 #  include <config.h>
  24 #endif
  25
  26 #include <stdio.h>
  27 #include <stdlib.h>
  28 #include <errno.h>
  29
  30 #include "libguile/_scm.h"
  31
  32 #include "libguile/async.h"
  33 #include "libguile/goops.h"
  34 #include "libguile/instructions.h"
  35 #include "libguile/objcodes.h"
  36 #include "libguile/programs.h"
  37
  38 #include "libguile/smob.h"
  39
  40 #include "libguile/bdw-gc.h"
  41 #include <gc/gc_mark.h>
  42
  43
  44 \f
  45
  46 /* scm_smobs scm_numsmob
  47  * implement a fixed sized array of smob records.
  48  * Indexes into this table are used when generating type
  49  * tags for smobjects (if you know a tag you can get an index and conversely).
  50  */
  51
  52 #define MAX_SMOB_COUNT SCM_I_MAX_SMOB_TYPE_COUNT
  53
  54 long scm_numsmob;
  55 scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];
  56
  57 void
  58 scm_assert_smob_type (scm_t_bits tag, SCM val)
  59 {
  60   if (!SCM_SMOB_PREDICATE (tag, val))
  61     scm_wrong_type_arg_msg (NULL, 0, val, scm_smobs[SCM_TC2SMOBNUM(tag)].name);
  62 }
  63
  64 /* {Mark}
  65  */
  66
  67 /* This function is vestigial.  It used to be the mark function's
  68    responsibility to set the mark bit on the smob or port, but now the
  69    generic marking routine in gc.c takes care of that, and a zero
  70    pointer for a mark function means "don't bother".  So you never
  71    need scm_mark0.
  72
  73    However, we leave it here because it's harmless to call it, and
  74    people out there have smob code that uses it, and there's no reason
  75    to make their links fail.  */
  76
  77 SCM
  78 scm_mark0 (SCM ptr SCM_UNUSED)
  79 {
  80   return SCM_BOOL_F;
  81 }
  82
  83 SCM
  84 /* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
  85    be used for real pairs. */
  86 scm_markcdr (SCM ptr)
  87 {
  88   return SCM_CELL_OBJECT_1 (ptr);
  89 }
  90
  91 \f
  92 /* {Free}
  93  */
  94
  95 size_t
  96 scm_free0 (SCM ptr SCM_UNUSED)
  97 {
  98   return 0;
  99 }
 100
 101 \f
 102 /* {Print}
 103  */
 104
 105 int
 106 scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 107 {
 108   long n = SCM_SMOBNUM (exp);
 109   scm_puts_unlocked ("#<", port);
 110   scm_puts_unlocked (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
 111   scm_putc_unlocked (' ', port);
 112   if (scm_smobs[n].size)
 113     scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
 114   else
 115     scm_uintprint (SCM_UNPACK (exp), 16, port);
 116   scm_putc_unlocked ('>', port);
 117   return 1;
 118 }
 119
 120 \f
 121 /* {Apply}
 122  */
 123
 124 static SCM scm_smob_trampolines[16];
 125
 126 /* (nargs * nargs) + nopt + rest * (nargs + 1) */
 127 #define SCM_SMOB_TRAMPOLINE(nreq,nopt,rest) \
 128   scm_smob_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
 129                        + nopt + rest * (nreq + nopt + rest + 1)]
 130
 131 static SCM
 132 apply_0 (SCM smob)
 133 {
 134   SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
 135   return subr (smob);
 136 }
 137
 138 static SCM
 139 apply_1 (SCM smob, SCM a)
 140 {
 141   SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
 142   return subr (smob, a);
 143 }
 144
 145 static SCM
 146 apply_2 (SCM smob, SCM a, SCM b)
 147 {
 148   SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
 149   return subr (smob, a, b);
 150 }
 151
 152 static SCM
 153 apply_3 (SCM smob, SCM a, SCM b, SCM c)
 154 {
 155   SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
 156   return subr (smob, a, b, c);
 157 }
 158
 159 static SCM
 160 scm_smob_trampoline (unsigned int nreq, unsigned int nopt,
 161                      unsigned int rest)
 162 {
 163   SCM trampoline;
 164
 165   if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 3))
 166     scm_out_of_range ("make-smob", scm_from_uint (nreq + nopt + rest));
 167
 168   trampoline = SCM_SMOB_TRAMPOLINE (nreq, nopt, rest);
 169
 170   if (SCM_LIKELY (SCM_UNPACK (trampoline)))
 171     return trampoline;
 172
 173   switch (nreq + nopt + rest)
 174     {
 175       /* The + 1 is for the smob itself.  */
 176     case 0:
 177       trampoline = scm_c_make_gsubr ("apply-smob/0", nreq + 1, nopt, rest,
 178                                      apply_0);
 179       break;
 180     case 1:
 181       trampoline = scm_c_make_gsubr ("apply-smob/1", nreq + 1, nopt, rest,
 182                                      apply_1);
 183       break;
 184     case 2:
 185       trampoline = scm_c_make_gsubr ("apply-smob/2", nreq + 1, nopt, rest,
 186                                      apply_2);
 187       break;
 188     case 3:
 189       trampoline = scm_c_make_gsubr ("apply-smob/3", nreq + 1, nopt, rest,
 190                                      apply_3);
 191       break;
 192     default:
 193       abort ();
 194     }
 195
 196   SCM_SMOB_TRAMPOLINE (nreq, nopt, rest) = trampoline;
 197
 198   return trampoline;
 199 }
 200
 201 \f
 202
 203 scm_t_bits
 204 scm_make_smob_type (char const *name, size_t size)
 205 #define FUNC_NAME "scm_make_smob_type"
 206 {
 207   long new_smob;
 208
 209   SCM_CRITICAL_SECTION_START;
 210   new_smob = scm_numsmob;
 211   if (scm_numsmob != MAX_SMOB_COUNT)
 212     ++scm_numsmob;
 213   SCM_CRITICAL_SECTION_END;
 214
 215   if (new_smob == MAX_SMOB_COUNT)
 216     scm_misc_error (FUNC_NAME, "maximum number of smobs exceeded", SCM_EOL);
 217
 218   scm_smobs[new_smob].name = name;
 219   scm_smobs[new_smob].size = size;
 220
 221   /* Make a class object if Goops is present. */
 222   if (SCM_UNPACK (scm_smob_class[0]) != 0)
 223     scm_smob_class[new_smob] = scm_make_extended_class (name, 0);
 224
 225   return scm_tc7_smob + new_smob * 256;
 226 }
 227 #undef FUNC_NAME
 228
 229
 230 void
 231 scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM))
 232 {
 233   scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark;
 234 }
 235
 236 void
 237 scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM))
 238 {
 239   scm_smobs[SCM_TC2SMOBNUM (tc)].free = free;
 240 }
 241
 242 void
 243 scm_set_smob_print (scm_t_bits tc, int (*print) (SCM, SCM, scm_print_state*))
 244 {
 245   scm_smobs[SCM_TC2SMOBNUM (tc)].print = print;
 246 }
 247
 248 void
 249 scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM))
 250 {
 251   scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp;
 252 }
 253
 254 void
 255 scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
 256                     unsigned int req, unsigned int opt, unsigned int rst)
 257 {
 258   SCM trampoline = scm_smob_trampoline (req, opt, rst);
 259
 260   scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
 261   scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline = trampoline;
 262
 263   if (SCM_UNPACK (scm_smob_class[0]) != 0)
 264     scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
 265 }
 266
 267 SCM
 268 scm_make_smob (scm_t_bits tc)
 269 {
 270   scm_t_bits n = SCM_TC2SMOBNUM (tc);
 271   size_t size = scm_smobs[n].size;
 272   scm_t_bits data = (size > 0
 273                      ? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n))
 274                      : 0);
 275
 276   SCM_RETURN_NEWSMOB (tc, data);
 277 }
 278
 279
 280 \f
 281 /* Marking SMOBs using user-supplied mark procedures.  */
 282
 283
 284 /* The GC kind used for SMOB types that provide a custom mark procedure.  */
 285 static int smob_gc_kind;
 286
 287 /* Mark stack pointer and limit, used by `scm_gc_mark'.  */
 288 static scm_i_pthread_key_t current_mark_stack_pointer;
 289 static scm_i_pthread_key_t current_mark_stack_limit;
 290
 291
 292 /* The generic SMOB mark procedure that gets called for SMOBs allocated
 293    with smob_gc_kind.  */
 294 static struct GC_ms_entry *
 295 smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 296            struct GC_ms_entry *mark_stack_limit, GC_word env)
 297 {
 298   register SCM cell;
 299   register scm_t_bits tc, smobnum;
 300
 301   cell = SCM_PACK_POINTER (addr);
 302
 303   if (SCM_TYP7 (cell) != scm_tc7_smob)
 304     /* It is likely that the GC passed us a pointer to a free-list element
 305        which we must ignore (see warning in `gc/gc_mark.h').  */
 306     return mark_stack_ptr;
 307
 308   tc = SCM_CELL_WORD_0 (cell);
 309   smobnum = SCM_TC2SMOBNUM (tc);
 310
 311   if (smobnum >= scm_numsmob)
 312     /* The first word looks corrupt.  */
 313     abort ();
 314
 315   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)),
 316                                      mark_stack_ptr,
 317                                      mark_stack_limit, NULL);
 318   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)),
 319                                      mark_stack_ptr,
 320                                      mark_stack_limit, NULL);
 321   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell)),
 322                                      mark_stack_ptr,
 323                                      mark_stack_limit, NULL);
 324
 325   if (scm_smobs[smobnum].mark)
 326     {
 327       SCM obj;
 328
 329       scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
 330       scm_i_pthread_setspecific (current_mark_stack_limit, mark_stack_limit);
 331
 332       /* Invoke the SMOB's mark procedure, which will in turn invoke
 333          `scm_gc_mark', which may modify `current_mark_stack_pointer'.  */
 334       obj = scm_smobs[smobnum].mark (cell);
 335
 336       mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
 337
 338       if (SCM_HEAP_OBJECT_P (obj))
 339         /* Mark the returned object.  */
 340         mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj),
 341                                            mark_stack_ptr,
 342                                            mark_stack_limit, NULL);
 343
 344       scm_i_pthread_setspecific (current_mark_stack_pointer, NULL);
 345       scm_i_pthread_setspecific (current_mark_stack_limit, NULL);
 346     }
 347
 348   return mark_stack_ptr;
 349
 350 }
 351
 352 /* Mark object O.  We assume that this function is only called during the mark
 353    phase, i.e., from within `smob_mark' or one of its descendants.  */
 354 void
 355 scm_gc_mark (SCM o)
 356 {
 357   if (SCM_HEAP_OBJECT_P (o))
 358     {
 359       void *mark_stack_ptr, *mark_stack_limit;
 360
 361       mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
 362       mark_stack_limit = scm_i_pthread_getspecific (current_mark_stack_limit);
 363
 364       if (mark_stack_ptr == NULL)
 365         /* The function was not called from a mark procedure.  */
 366         abort ();
 367
 368       mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o),
 369                                          mark_stack_ptr, mark_stack_limit,
 370                                          NULL);
 371       scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
 372     }
 373 }
 374
 375 \f
 376 /* Finalize SMOB by calling its SMOB type's free function, if any.  */
 377 static void
 378 finalize_smob (void *ptr, void *data)
 379 {
 380   SCM smob;
 381   size_t (* free_smob) (SCM);
 382
 383   smob = SCM_PACK_POINTER (ptr);
 384 #if 0
 385   printf ("finalizing SMOB %p (smobnum: %u)\n",
 386           ptr, SCM_SMOBNUM (smob));
 387 #endif
 388
 389   free_smob = scm_smobs[SCM_SMOBNUM (smob)].free;
 390   if (free_smob)
 391     free_smob (smob);
 392 }
 393
 394 /* Return a SMOB with typecode TC.  The SMOB type corresponding to TC may
 395    provide a custom mark procedure and it will be honored.  */
 396 SCM
 397 scm_i_new_smob (scm_t_bits tc, scm_t_bits data)
 398 {
 399   scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
 400   SCM ret;
 401
 402   /* Use the smob_gc_kind if needed to allow the mark procedure to
 403      run.  Since the marker only deals with double cells, that case
 404      allocates a double cell.  We leave words 2 and 3 to there initial
 405      values, which is 0.  */
 406   if (scm_smobs [smobnum].mark)
 407     ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
 408   else
 409     ret = SCM_PACK_POINTER (GC_MALLOC (sizeof (scm_t_cell)));
 410
 411   SCM_SET_CELL_WORD_1 (ret, data);
 412   SCM_SET_CELL_WORD_0 (ret, tc);
 413
 414   if (scm_smobs[smobnum].free)
 415     scm_i_set_finalizer (SCM2PTR (ret), finalize_smob, NULL);
 416
 417   return ret;
 418 }
 419
 420 /* Return a SMOB with typecode TC.  The SMOB type corresponding to TC may
 421    provide a custom mark procedure and it will be honored.  */
 422 SCM
 423 scm_i_new_double_smob (scm_t_bits tc, scm_t_bits data1,
 424                        scm_t_bits data2, scm_t_bits data3)
 425 {
 426   scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
 427   SCM ret;
 428
 429   /* Use the smob_gc_kind if needed to allow the mark procedure to
 430      run.  */
 431   if (scm_smobs [smobnum].mark)
 432     ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
 433   else
 434     ret = SCM_PACK_POINTER (GC_MALLOC (2 * sizeof (scm_t_cell)));
 435
 436   SCM_SET_CELL_WORD_3 (ret, data3);
 437   SCM_SET_CELL_WORD_2 (ret, data2);
 438   SCM_SET_CELL_WORD_1 (ret, data1);
 439   SCM_SET_CELL_WORD_0 (ret, tc);
 440
 441   if (scm_smobs[smobnum].free)
 442     scm_i_set_finalizer (SCM2PTR (ret), finalize_smob, NULL);
 443
 444   return ret;
 445 }
 446
 447 \f
 448 void
 449 scm_smob_prehistory ()
 450 {
 451   long i;
 452
 453   scm_i_pthread_key_create (&current_mark_stack_pointer, NULL);
 454   scm_i_pthread_key_create (&current_mark_stack_limit, NULL);
 455
 456   smob_gc_kind = GC_new_kind (GC_new_free_list (),
 457                               GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
 458                               0,
 459                               /* Clear new objects.  As of version 7.1, libgc
 460                                  doesn't seem to support passing 0 here.  */
 461                               1);
 462
 463   scm_numsmob = 0;
 464   for (i = 0; i < MAX_SMOB_COUNT; ++i)
 465     {
 466       scm_smobs[i].name       = 0;
 467       scm_smobs[i].size       = 0;
 468       scm_smobs[i].mark       = 0;
 469       scm_smobs[i].free       = 0;
 470       scm_smobs[i].print      = scm_smob_print;
 471       scm_smobs[i].equalp     = 0;
 472       scm_smobs[i].apply      = 0;
 473       scm_smobs[i].apply_trampoline = SCM_BOOL_F;
 474     }
 475 }
 476
 477 /*
 478   Local Variables:
 479   c-file-style: "gnu"
 480   End:
 481 */