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 ("#<", port);
 110   scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
 111   scm_putc (' ', 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 ('>', 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   /* In 2.2 this field is renamed to "apply_trampoline".  */
 262   scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline_objcode = trampoline;
 263
 264   if (SCM_UNPACK (scm_smob_class[0]) != 0)
 265     scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
 266 }
 267
 268 SCM
 269 scm_make_smob (scm_t_bits tc)
 270 {
 271   scm_t_bits n = SCM_TC2SMOBNUM (tc);
 272   size_t size = scm_smobs[n].size;
 273   scm_t_bits data = (size > 0
 274                      ? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n))
 275                      : 0);
 276
 277   SCM_RETURN_NEWSMOB (tc, data);
 278 }
 279
 280
 281 \f
 282 /* Marking SMOBs using user-supplied mark procedures.  */
 283
 284
 285 /* The GC kind used for SMOB types that provide a custom mark procedure.  */
 286 static int smob_gc_kind;
 287
 288 /* Mark stack pointer and limit, used by `scm_gc_mark'.  */
 289 static scm_i_pthread_key_t current_mark_stack_pointer;
 290 static scm_i_pthread_key_t current_mark_stack_limit;
 291
 292
 293 /* The generic SMOB mark procedure that gets called for SMOBs allocated
 294    with smob_gc_kind.  */
 295 static struct GC_ms_entry *
 296 smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 297            struct GC_ms_entry *mark_stack_limit, GC_word env)
 298 {
 299   register SCM cell;
 300   register scm_t_bits tc, smobnum;
 301
 302   cell = PTR2SCM (addr);
 303
 304   if (SCM_TYP7 (cell) != scm_tc7_smob)
 305     /* It is likely that the GC passed us a pointer to a free-list element
 306        which we must ignore (see warning in `gc/gc_mark.h').  */
 307     return mark_stack_ptr;
 308
 309   tc = SCM_CELL_WORD_0 (cell);
 310   smobnum = SCM_TC2SMOBNUM (tc);
 311
 312   if (smobnum >= scm_numsmob)
 313     /* The first word looks corrupt.  */
 314     abort ();
 315
 316   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)),
 317                                      mark_stack_ptr,
 318                                      mark_stack_limit, NULL);
 319   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)),
 320                                      mark_stack_ptr,
 321                                      mark_stack_limit, NULL);
 322   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell)),
 323                                      mark_stack_ptr,
 324                                      mark_stack_limit, NULL);
 325
 326   if (scm_smobs[smobnum].mark)
 327     {
 328       SCM obj;
 329
 330       scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
 331       scm_i_pthread_setspecific (current_mark_stack_limit, mark_stack_limit);
 332
 333       /* Invoke the SMOB's mark procedure, which will in turn invoke
 334          `scm_gc_mark', which may modify `current_mark_stack_pointer'.  */
 335       obj = scm_smobs[smobnum].mark (cell);
 336
 337       mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
 338
 339       if (SCM_NIMP (obj))
 340         /* Mark the returned object.  */
 341         mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj),
 342                                            mark_stack_ptr,
 343                                            mark_stack_limit, NULL);
 344
 345       scm_i_pthread_setspecific (current_mark_stack_pointer, NULL);
 346       scm_i_pthread_setspecific (current_mark_stack_limit, NULL);
 347     }
 348
 349   return mark_stack_ptr;
 350
 351 }
 352
 353 /* Mark object O.  We assume that this function is only called during the mark
 354    phase, i.e., from within `smob_mark' or one of its descendants.  */
 355 void
 356 scm_gc_mark (SCM o)
 357 {
 358   if (SCM_NIMP (o))
 359     {
 360       void *mark_stack_ptr, *mark_stack_limit;
 361
 362       mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
 363       mark_stack_limit = scm_i_pthread_getspecific (current_mark_stack_limit);
 364
 365       if (mark_stack_ptr == NULL)
 366         /* The function was not called from a mark procedure.  */
 367         abort ();
 368
 369       mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o),
 370                                          mark_stack_ptr, mark_stack_limit,
 371                                          NULL);
 372       scm_i_pthread_setspecific (current_mark_stack_pointer, mark_stack_ptr);
 373     }
 374 }
 375
 376 \f
 377 /* Finalize SMOB by calling its SMOB type's free function, if any.  */
 378 static void
 379 finalize_smob (void *ptr, void *data)
 380 {
 381   SCM smob;
 382   size_t (* free_smob) (SCM);
 383
 384   smob = PTR2SCM (ptr);
 385 #if 0
 386   printf ("finalizing SMOB %p (smobnum: %u)\n",
 387           ptr, SCM_SMOBNUM (smob));
 388 #endif
 389
 390   free_smob = scm_smobs[SCM_SMOBNUM (smob)].free;
 391   if (free_smob)
 392     free_smob (smob);
 393 }
 394
 395 /* Return a SMOB with typecode TC.  The SMOB type corresponding to TC may
 396    provide a custom mark procedure and it will be honored.  */
 397 SCM
 398 scm_i_new_smob (scm_t_bits tc, scm_t_bits data)
 399 {
 400   scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
 401   SCM ret;
 402
 403   /* Use the smob_gc_kind if needed to allow the mark procedure to
 404      run.  Since the marker only deals with double cells, that case
 405      allocates a double cell.  We leave words 2 and 3 to there initial
 406      values, which is 0.  */
 407   if (scm_smobs [smobnum].mark)
 408     ret = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
 409   else
 410     ret = PTR2SCM (GC_MALLOC (sizeof (scm_t_cell)));
 411
 412   SCM_SET_CELL_WORD_1 (ret, data);
 413   SCM_SET_CELL_WORD_0 (ret, tc);
 414
 415   if (scm_smobs[smobnum].free)
 416     scm_i_set_finalizer (SCM2PTR (ret), finalize_smob, NULL);
 417
 418   return ret;
 419 }
 420
 421 /* Return a SMOB with typecode TC.  The SMOB type corresponding to TC may
 422    provide a custom mark procedure and it will be honored.  */
 423 SCM
 424 scm_i_new_double_smob (scm_t_bits tc, scm_t_bits data1,
 425                        scm_t_bits data2, scm_t_bits data3)
 426 {
 427   scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
 428   SCM ret;
 429
 430   /* Use the smob_gc_kind if needed to allow the mark procedure to
 431      run.  */
 432   if (scm_smobs [smobnum].mark)
 433     ret = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
 434   else
 435     ret = PTR2SCM (GC_MALLOC (2 * sizeof (scm_t_cell)));
 436
 437   SCM_SET_CELL_WORD_3 (ret, data3);
 438   SCM_SET_CELL_WORD_2 (ret, data2);
 439   SCM_SET_CELL_WORD_1 (ret, data1);
 440   SCM_SET_CELL_WORD_0 (ret, tc);
 441
 442   if (scm_smobs[smobnum].free)
 443     scm_i_set_finalizer (SCM2PTR (ret), finalize_smob, NULL);
 444
 445   return ret;
 446 }
 447
 448
 449 \f
 450
 451 /* These two are internal details of the previous implementation of
 452    SCM_NEWSMOB and are no longer used.  They are still here to preserve
 453    ABI stability in the 2.0 series.  */
 454 void
 455 scm_i_finalize_smob (void *ptr, void *data)
 456 {
 457   finalize_smob (ptr, data);
 458 }
 459
 460 SCM
 461 scm_i_new_smob_with_mark_proc (scm_t_bits tc, scm_t_bits word1,
 462                                scm_t_bits word2, scm_t_bits word3)
 463 {
 464   return scm_new_double_smob (tc, word1, word2, word3);
 465 }
 466
 467
 468 \f
 469 void
 470 scm_smob_prehistory ()
 471 {
 472   long i;
 473
 474   scm_i_pthread_key_create (&current_mark_stack_pointer, NULL);
 475   scm_i_pthread_key_create (&current_mark_stack_limit, NULL);
 476
 477   smob_gc_kind = GC_new_kind (GC_new_free_list (),
 478                               GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
 479                               0,
 480                               /* Clear new objects.  As of version 7.1, libgc
 481                                  doesn't seem to support passing 0 here.  */
 482                               1);
 483
 484   scm_numsmob = 0;
 485   for (i = 0; i < MAX_SMOB_COUNT; ++i)
 486     {
 487       scm_smobs[i].name       = 0;
 488       scm_smobs[i].size       = 0;
 489       scm_smobs[i].mark       = 0;
 490       scm_smobs[i].free       = 0;
 491       scm_smobs[i].print      = scm_smob_print;
 492       scm_smobs[i].equalp     = 0;
 493       scm_smobs[i].apply      = 0;
 494       scm_smobs[i].apply_trampoline_objcode = SCM_BOOL_F;
 495     }
 496 }
 497
 498 /*
 499   Local Variables:
 500   c-file-style: "gnu"
 501   End:
 502 */