libguile/smob.c

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