libguile/smob.c

   1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19
  20 \f
  21 #ifdef HAVE_CONFIG_H
  22 #  include <config.h>
  23 #endif
  24
  25 #include <stdio.h>
  26 #include <stdlib.h>
  27 #include <errno.h>
  28
  29 #include "libguile/_scm.h"
  30
  31 #include "libguile/async.h"
  32 #include "libguile/goops.h"
  33 #include "libguile/instructions.h"
  34 #include "libguile/objcodes.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_CRITICAL_SECTION_START;
 209   new_smob = scm_numsmob;
 210   if (scm_numsmob != MAX_SMOB_COUNT)
 211     ++scm_numsmob;
 212   SCM_CRITICAL_SECTION_END;
 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_smob_class[0]) != 0)
 222     scm_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_smob_class[0]) != 0)
 263     scm_i_inherit_applicable (scm_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
 287 /* The generic SMOB mark procedure that gets called for SMOBs allocated
 288    with smob_gc_kind.  */
 289 static struct GC_ms_entry *
 290 smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 291            struct GC_ms_entry *mark_stack_limit, GC_word env)
 292 {
 293   register SCM cell;
 294   register scm_t_bits tc, smobnum;
 295
 296   cell = SCM_PACK_POINTER (addr);
 297
 298   if (SCM_TYP7 (cell) != scm_tc7_smob)
 299     /* It is likely that the GC passed us a pointer to a free-list element
 300        which we must ignore (see warning in `gc/gc_mark.h').  */
 301     return mark_stack_ptr;
 302
 303   tc = SCM_CELL_WORD_0 (cell);
 304   smobnum = SCM_TC2SMOBNUM (tc);
 305
 306   if (smobnum >= scm_numsmob)
 307     /* The first word looks corrupt.  */
 308     abort ();
 309
 310   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)),
 311                                      mark_stack_ptr,
 312                                      mark_stack_limit, NULL);
 313   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)),
 314                                      mark_stack_ptr,
 315                                      mark_stack_limit, NULL);
 316   mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell)),
 317                                      mark_stack_ptr,
 318                                      mark_stack_limit, NULL);
 319
 320   if (scm_smobs[smobnum].mark)
 321     {
 322       SCM obj;
 323
 324       SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
 325       SCM_I_CURRENT_THREAD->current_mark_stack_limit = mark_stack_limit;
 326
 327       /* Invoke the SMOB's mark procedure, which will in turn invoke
 328          `scm_gc_mark ()', which may modify `current_mark_stack_ptr'.  */
 329       obj = scm_smobs[smobnum].mark (cell);
 330
 331       mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr;
 332
 333       if (SCM_HEAP_OBJECT_P (obj))
 334         /* Mark the returned object.  */
 335         mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj),
 336                                            mark_stack_ptr,
 337                                            mark_stack_limit, NULL);
 338
 339       SCM_I_CURRENT_THREAD->current_mark_stack_limit = NULL;
 340       SCM_I_CURRENT_THREAD->current_mark_stack_ptr = NULL;
 341     }
 342
 343   return mark_stack_ptr;
 344
 345 }
 346
 347 /* Mark object O.  We assume that this function is only called during the
 348    mark phase, i.e., from within `smob_mark ()' or one of its
 349    descendents.  */
 350 void
 351 scm_gc_mark (SCM o)
 352 {
 353 #define CURRENT_MARK_PTR                                                 \
 354   ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_ptr))
 355 #define CURRENT_MARK_LIMIT                                                 \
 356   ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit))
 357
 358   if (SCM_HEAP_OBJECT_P (o))
 359     {
 360       /* At this point, the `current_mark_*' fields of the current thread
 361          must be defined (they are set in `smob_mark ()').  */
 362       register struct GC_ms_entry *mark_stack_ptr;
 363
 364       if (!CURRENT_MARK_PTR)
 365         /* The function was not called from a mark procedure.  */
 366         abort ();
 367
 368       mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o),
 369                                          CURRENT_MARK_PTR, CURRENT_MARK_LIMIT,
 370                                          NULL);
 371       SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr;
 372     }
 373 #undef CURRENT_MARK_PTR
 374 #undef CURRENT_MARK_LIMIT
 375 }
 376
 377 \f
 378 /* Finalize SMOB by calling its SMOB type's free function, if any.  */
 379 static void
 380 finalize_smob (void *ptr, void *data)
 381 {
 382   SCM smob;
 383   size_t (* free_smob) (SCM);
 384
 385   smob = SCM_PACK_POINTER (ptr);
 386 #if 0
 387   printf ("finalizing SMOB %p (smobnum: %u)\n",
 388           ptr, SCM_SMOBNUM (smob));
 389 #endif
 390
 391   free_smob = scm_smobs[SCM_SMOBNUM (smob)].free;
 392   if (free_smob)
 393     free_smob (smob);
 394 }
 395
 396 /* Return a SMOB with typecode TC.  The SMOB type corresponding to TC may
 397    provide a custom mark procedure and it will be honored.  */
 398 SCM
 399 scm_i_new_smob (scm_t_bits tc, scm_t_bits data)
 400 {
 401   scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
 402   SCM ret;
 403
 404   /* Use the smob_gc_kind if needed to allow the mark procedure to
 405      run.  Since the marker only deals with double cells, that case
 406      allocates a double cell.  We leave words 2 and 3 to there initial
 407      values, which is 0.  */
 408   if (scm_smobs [smobnum].mark)
 409     ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
 410   else
 411     ret = SCM_PACK_POINTER (GC_MALLOC (sizeof (scm_t_cell)));
 412
 413   SCM_SET_CELL_WORD_1 (ret, data);
 414   SCM_SET_CELL_WORD_0 (ret, tc);
 415
 416   if (scm_smobs[smobnum].free)
 417     scm_i_set_finalizer (SCM2PTR (ret), finalize_smob, NULL);
 418
 419   return ret;
 420 }
 421
 422 /* Return a SMOB with typecode TC.  The SMOB type corresponding to TC may
 423    provide a custom mark procedure and it will be honored.  */
 424 SCM
 425 scm_i_new_double_smob (scm_t_bits tc, scm_t_bits data1,
 426                        scm_t_bits data2, scm_t_bits data3)
 427 {
 428   scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
 429   SCM ret;
 430
 431   /* Use the smob_gc_kind if needed to allow the mark procedure to
 432      run.  */
 433   if (scm_smobs [smobnum].mark)
 434     ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
 435   else
 436     ret = SCM_PACK_POINTER (GC_MALLOC (2 * sizeof (scm_t_cell)));
 437
 438   SCM_SET_CELL_WORD_3 (ret, data3);
 439   SCM_SET_CELL_WORD_2 (ret, data2);
 440   SCM_SET_CELL_WORD_1 (ret, data1);
 441   SCM_SET_CELL_WORD_0 (ret, tc);
 442
 443   if (scm_smobs[smobnum].free)
 444     scm_i_set_finalizer (SCM2PTR (ret), finalize_smob, NULL);
 445
 446   return ret;
 447 }
 448
 449 \f
 450 void
 451 scm_smob_prehistory ()
 452 {
 453   long i;
 454
 455   smob_gc_kind = GC_new_kind (GC_new_free_list (),
 456                               GC_MAKE_PROC (GC_new_proc (smob_mark), 0),
 457                               0,
 458                               /* Clear new objects.  As of version 7.1, libgc
 459                                  doesn't seem to support passing 0 here.  */
 460                               1);
 461
 462   scm_numsmob = 0;
 463   for (i = 0; i < MAX_SMOB_COUNT; ++i)
 464     {
 465       scm_smobs[i].name       = 0;
 466       scm_smobs[i].size       = 0;
 467       scm_smobs[i].mark       = 0;
 468       scm_smobs[i].free       = 0;
 469       scm_smobs[i].print      = scm_smob_print;
 470       scm_smobs[i].equalp     = 0;
 471       scm_smobs[i].apply      = 0;
 472       scm_smobs[i].apply_trampoline = SCM_BOOL_F;
 473     }
 474 }
 475
 476 /*
 477   Local Variables:
 478   c-file-style: "gnu"
 479   End:
 480 */