src/pmc.c

   1 /*
   2 Copyright (C) 2001-2006, The Perl Foundation.
   3 $Id$
   4
   5 =head1 NAME
   6
   7 src/pmc.c - The base vtable calling functions
   8
   9 =head1 DESCRIPTION
  10
  11 =head2 Functions
  12
  13 =over 4
  14
  15 =cut
  16
  17 */
  18
  19 #include "parrot/parrot.h"
  20 #include <assert.h>
  21 #include "pmc.str"
  22
  23 static PMC* get_new_pmc_header(Interp*, INTVAL base_type, UINTVAL flags);
  24
  25
  26 PMC * PMCNULL;
  27
  28 /*
  29
  30 =item C<PMC *
  31 pmc_new(Interp *interp, INTVAL base_type)>
  32
  33 Creates a new PMC of type C<base_type> (which is an index into the list
  34 of PMC types declared in C<vtables> in
  35 F<include/parrot/pmc.h>). Once the PMC has been successfully created and
  36 its vtable pointer initialized, we call its C<init> method to perform
  37 any other necessary initialization.
  38
  39 =cut
  40
  41 */
  42
  43 PMC *
  44 pmc_new(Interp *interp, INTVAL base_type)
  45 {
  46     PMC * const pmc = pmc_new_noinit(interp, base_type);
  47     VTABLE_init(interp, pmc);
  48     return pmc;
  49 }
  50
  51 /*
  52
  53 =item C<PMC *
  54 pmc_reuse(Interp *interp, PMC *pmc, INTVAL new_type,
  55           UINTVAL flags)>
  56
  57 Reuse an existing PMC, turning it into an empty PMC of the new
  58 type. Any required internal structure will be put in place (such as
  59 the extension area) and the PMC will be ready to go. This will throw
  60 an exception if the PMC is constant or of a singleton type (such as
  61 the environment PMC) or is being turned into a PMC of a singleton
  62 type.
  63
  64 =cut
  65
  66 */
  67
  68 PMC*
  69 pmc_reuse(Interp *interp, PMC *pmc, INTVAL new_type,
  70           UINTVAL flags)
  71 {
  72     INTVAL has_ext, new_flags;
  73     VTABLE *new_vtable;
  74
  75     if (pmc->vtable->base_type == new_type)
  76         return pmc;
  77
  78     new_vtable = interp->vtables[new_type];
  79
  80     /* Singleton/const PMCs/types are not eligible */
  81
  82     if ((pmc->vtable->flags | new_vtable->flags)
  83         & (VTABLE_PMC_IS_SINGLETON | VTABLE_IS_CONST_FLAG))
  84     {
  85         /* First, is the destination a singleton? No joy for us there */
  86         if (new_vtable->flags & VTABLE_PMC_IS_SINGLETON) {
  87             internal_exception(ALLOCATION_ERROR,
  88                                "Parrot VM: Can't turn to a singleton type!\n");
  89             return NULL;
  90         }
  91
  92         /* First, is the destination a constant? No joy for us there */
  93         if (new_vtable->flags & VTABLE_IS_CONST_FLAG) {
  94             internal_exception(ALLOCATION_ERROR,
  95                                "Parrot VM: Can't turn to a constant type!\n");
  96             return NULL;
  97         }
  98
  99         /* Is the source a singleton? */
 100         if (pmc->vtable->flags & VTABLE_PMC_IS_SINGLETON) {
 101             internal_exception(ALLOCATION_ERROR,
 102                                "Parrot VM: Can't modify a singleton\n");
 103             return NULL;
 104         }
 105
 106         /* Is the source constant? */
 107         if (pmc->vtable->flags & VTABLE_IS_CONST_FLAG) {
 108             internal_exception(ALLOCATION_ERROR,
 109                                "Parrot VM: Can't modify a constant\n");
 110             return NULL;
 111         }
 112     }
 113
 114     /* Do we have an extension area? */
 115     has_ext = (PObj_is_PMC_EXT_TEST(pmc) && pmc->pmc_ext);
 116
 117     /* Do we need one? */
 118     if (new_vtable->flags & VTABLE_PMC_NEEDS_EXT) {
 119         if (!has_ext) {
 120             /* If we need an ext area, go allocate one */
 121             add_pmc_ext(interp, pmc);
 122         }
 123         new_flags = PObj_is_PMC_EXT_FLAG;
 124     }
 125     else {
 126         if (has_ext) {
 127             /* if the PMC has a PMC_EXT structure,
 128              * return it to the pool/arena
 129              */
 130             Small_Object_Pool * const ext_pool =
 131                 interp->arena_base->pmc_ext_pool;
 132             if (PObj_is_PMC_shared_TEST(pmc) && PMC_sync(pmc)) {
 133                 MUTEX_DESTROY(PMC_sync(pmc)->pmc_lock);
 134                 mem_internal_free(PMC_sync(pmc));
 135                 PMC_sync(pmc) = NULL;
 136             }
 137             ext_pool->add_free_object(interp, ext_pool, pmc->pmc_ext);
 138         }
 139         pmc->pmc_ext = NULL;
 140 #if ! PMC_DATA_IN_EXT
 141         PMC_data(pmc) = NULL;
 142 #endif
 143         new_flags = 0;
 144     }
 145
 146     /* we are a PMC + maybe is_PMC_EXT */
 147     PObj_flags_SETTO(pmc, PObj_is_PMC_FLAG | new_flags);
 148
 149     /* Set the right vtable */
 150     pmc->vtable = new_vtable;
 151
 152     /* Call the base init for the redone pmc */
 153     VTABLE_init(interp, pmc);
 154
 155     return pmc;
 156 }
 157
 158 /*
 159
 160 =item C<static PMC*
 161 get_new_pmc_header(Interp *interp, INTVAL base_type, UINTVAL flags)>
 162
 163 Gets a new PMC header.
 164
 165 =cut
 166
 167 */
 168
 169 static PMC*
 170 get_new_pmc_header(Interp *interp, INTVAL base_type, UINTVAL flags)
 171 {
 172     PMC *pmc;
 173     VTABLE *vtable = interp->vtables[base_type];
 174
 175     if (!vtable) {
 176         /* This is usually because you either didn't call init_world early
 177          * enough, you added a new PMC class without adding
 178          * Parrot_(classname)_class_init to init_world, or you forgot
 179          * to run 'make realclean' after adding a new PMC class.
 180          */
 181         PANIC("Null vtable used");
 182     }
 183
 184     /* we only have one global Env object, living in the interp */
 185     if (vtable->flags & VTABLE_PMC_IS_SINGLETON) {
 186         /*
 187          * singletons (monadic objects) exist only once, the interface
 188          * with the class is:
 189          * - get_pointer: return NULL or a pointer to the single instance
 190          * - set_pointer: set the only instance once
 191          *
 192          * - singletons are created in the constant pmc pool
 193          */
 194         pmc = (PMC *)(vtable->get_pointer)(interp, NULL);
 195         /* LOCK */
 196         if (!pmc) {
 197             pmc = new_pmc_header(interp, PObj_constant_FLAG);
 198             pmc->vtable = vtable;
 199             VTABLE_set_pointer(interp, pmc, pmc);
 200         }
 201         return pmc;
 202     }
 203     if (vtable->flags & VTABLE_IS_CONST_PMC_FLAG) {
 204         flags = PObj_constant_FLAG;
 205     }
 206     else if (vtable->flags & VTABLE_IS_CONST_FLAG) {
 207         /* put the normal vtable in, so that the pmc can be initialized first
 208          * parrot or user code has to set the _ro property then,
 209          * to morph the PMC to the const variant
 210          * This assumes that a constant PMC enum is one bigger then
 211          * the normal one.
 212          */
 213
 214         /*
 215          * XXX not yet we can't assure that all contents in the
 216          * const PMC is const too
 217          * see e.g. t/pmc/sarray_13.pir
 218          */
 219 #if 0
 220         flags = PObj_constant_FLAG;
 221 #endif
 222         --base_type;
 223         vtable = interp->vtables[base_type];
 224     }
 225     if (vtable->flags & VTABLE_PMC_NEEDS_EXT) {
 226         flags |= PObj_is_PMC_EXT_FLAG;
 227         if (vtable->flags & VTABLE_IS_SHARED_FLAG)
 228             flags |= PObj_is_PMC_shared_FLAG;
 229     }
 230
 231     pmc = new_pmc_header(interp, flags);
 232     if (!pmc) {
 233         internal_exception(ALLOCATION_ERROR,
 234                 "Parrot VM: PMC allocation failed!\n");
 235         return NULL;
 236     }
 237
 238     pmc->vtable = vtable;
 239
 240 #if GC_VERBOSE
 241     if (Interp_flags_TEST(interp, PARROT_TRACE_FLAG)) {
 242         /* XXX make a more verbose trace flag */
 243         fprintf(stderr, "\t=> new %p type %d\n", pmc, (int)base_type);
 244     }
 245 #endif
 246     return pmc;
 247 }
 248
 249
 250 /*
 251
 252 =item C<PMC *
 253 pmc_new_noinit(Interp *interp, INTVAL base_type)>
 254
 255 Creates a new PMC of type C<base_type> (which is an index into the list
 256 of PMC types declared in C<vtables> in
 257 F<include/parrot/pmc.h>). Unlike C<pmc_new()>, C<pmc_new_noinit()> does
 258 not call its C<init> method.  This allows separate allocation and
 259 initialization for continuations.
 260
 261 =cut
 262
 263 */
 264
 265 PMC *
 266 pmc_new_noinit(Interp *interp, INTVAL base_type)
 267 {
 268     PMC * const pmc = get_new_pmc_header(interp, base_type, 0);
 269
 270     return pmc;
 271 }
 272
 273 /*
 274
 275 =item C<PMC *
 276 constant_pmc_new_noinit(Interp *interp, INTVAL base_type)>
 277
 278 Creates a new constant PMC of type C<base_type>.
 279
 280 =cut
 281
 282 */
 283
 284 PMC *
 285 constant_pmc_new_noinit(Interp *interp, INTVAL base_type)
 286 {
 287     PMC * const pmc = get_new_pmc_header(interp, base_type,
 288             PObj_constant_FLAG);
 289     return pmc;
 290 }
 291
 292 /*
 293
 294 =item C<PMC *
 295 constant_pmc_new(Interp *interp, INTVAL base_type)>
 296
 297 Creates a new constant PMC of type C<base_type>, the call C<init>.
 298
 299 =cut
 300
 301 */
 302
 303 PMC *
 304 constant_pmc_new(Interp *interp, INTVAL base_type)
 305 {
 306     PMC * const pmc = get_new_pmc_header(interp, base_type,
 307             PObj_constant_FLAG);
 308     VTABLE_init(interp, pmc);
 309     return pmc;
 310 }
 311
 312 /*
 313
 314 =item C<PMC *
 315 pmc_new_init(Interp *interp, INTVAL base_type, PMC *init)>
 316
 317 As C<pmc_new()>, but passes C<init> to the PMC's C<init_pmc()> method.
 318
 319 =cut
 320
 321 */
 322
 323 PMC *
 324 pmc_new_init(Interp *interp, INTVAL base_type, PMC *init)
 325 {
 326     PMC * const pmc = pmc_new_noinit(interp, base_type);
 327
 328     VTABLE_init_pmc(interp, pmc, init);
 329
 330     return pmc;
 331 }
 332
 333 /*
 334
 335 =item C<PMC *
 336 constant_pmc_new_init(Interp *interp, INTVAL base_type, PMC *init)>
 337
 338 As C<constant_pmc_new>, but passes C<init> to the PMC's C<init_pmc> method.
 339
 340 =cut
 341
 342 */
 343
 344 PMC *
 345 constant_pmc_new_init(Interp *interp, INTVAL base_type, PMC *init)
 346 {
 347     PMC * const pmc = get_new_pmc_header(interp, base_type, 1);
 348     VTABLE_init_pmc(interp, pmc, init);
 349     return pmc;
 350 }
 351
 352 /*
 353
 354 =item C<INTVAL
 355 pmc_register(Interp* interp, STRING *name)>
 356
 357 This segment handles PMC registration and such.
 358
 359 =cut
 360
 361 */
 362
 363 INTVAL
 364 pmc_register(Interp* interp, STRING *name)
 365 {
 366     INTVAL type;
 367     PMC *classname_hash;
 368     /* If they're looking to register an existing class, return that
 369        class' type number */
 370     if ((type = pmc_type(interp, name)) > enum_type_undef) {
 371         return type;
 372     }
 373     if (type < enum_type_undef) {
 374         internal_exception(1, "native type with name '%s' already exists - "
 375                 "can't register PMC", data_types[type].name);
 376         return 0;
 377     }
 378
 379     classname_hash = interp->class_hash;
 380     type = interp->n_vtable_max++;
 381     /* Have we overflowed the table? */
 382     if (type >= interp->n_vtable_alloced) {
 383         parrot_realloc_vtables(interp);
 384     }
 385     /* set entry in name->type hash */
 386     VTABLE_set_integer_keyed_str(interp, classname_hash, name, type);
 387     return type;
 388 }
 389
 390 /*
 391
 392 =item C<INTVAL
 393 pmc_type(Interp* interp, STRING *name)>
 394
 395 Returns the PMC type for C<name>.
 396
 397 =cut
 398
 399 */
 400
 401 INTVAL
 402 pmc_type(Interp* interp, const STRING *name)
 403 {
 404     PMC * const classname_hash = interp->class_hash;
 405     const PMC * const item = (PMC *)VTABLE_get_pointer_keyed_str(interp, classname_hash, name);
 406
 407     /* nested namespace with same name */
 408     if (item->vtable->base_type == enum_class_NameSpace)
 409         return 0;
 410     if (!PMC_IS_NULL(item))
 411         return PMC_int_val((PMC*) item);
 412     return Parrot_get_datatype_enum(interp, name);
 413 }
 414
 415 INTVAL
 416 pmc_type_p(Interp* interp, const PMC *name)
 417 {
 418     PMC * const classname_hash = interp->class_hash;
 419     PMC *item = (PMC *)VTABLE_get_pointer_keyed(interp, classname_hash, name);
 420
 421     if (!PMC_IS_NULL(item))
 422         return PMC_int_val((PMC*) item);
 423     return 0;
 424 }
 425
 426 static PMC*
 427 create_class_pmc(Interp *interp, INTVAL type)
 428 {
 429     /*
 430      * class interface - a PMC is its own class
 431      * put an instance of this PMC into class
 432      *
 433      * create a constant PMC
 434      */
 435     PMC * const _class = get_new_pmc_header(interp, type,
 436                                            PObj_constant_FLAG);
 437     /* If we are a second thread, we may get the same object as the
 438      * original because we have a singleton. Just set the singleton to
 439      * be our class object, but don't mess with its vtable.
 440      */
 441     if ((interp->vtables[type]->flags & VTABLE_PMC_IS_SINGLETON)
 442         && (_class == _class->vtable->pmc_class)) {
 443         interp->vtables[type]->pmc_class = _class;
 444         return _class;
 445     }
 446     if (PObj_is_PMC_EXT_TEST(_class)) {
 447         /* if the PMC has a PMC_EXT structure,
 448          * return it to the pool/arena
 449          * we don't need it - basically only the vtable is important
 450          */
 451         Small_Object_Pool * const ext_pool =
 452             interp->arena_base->pmc_ext_pool;
 453         if (PMC_sync(_class))
 454             mem_internal_free(PMC_sync(_class));
 455         ext_pool->add_free_object(interp, ext_pool, _class->pmc_ext);
 456     }
 457     _class->pmc_ext = NULL;
 458     DOD_flag_CLEAR(is_special_PMC, _class);
 459     PMC_pmc_val(_class)   = (PMC *)0xdeadbeef;
 460     PMC_struct_val(_class)= (void*)0xdeadbeef;
 461
 462     PObj_is_PMC_shared_CLEAR(_class);
 463
 464     interp->vtables[type]->pmc_class = _class;
 465
 466     return _class;
 467 }
 468
 469 /*
 470
 471 =item C<void Parrot_create_mro(Interp *interp, INTVAL type)>
 472
 473 Create the MRO (method resolution order) array for this type.
 474
 475 =cut
 476
 477 */
 478
 479 void
 480 Parrot_create_mro(Interp *interp, INTVAL type)
 481 {
 482     VTABLE *vtable;
 483     STRING *class_name, *isa;
 484     INTVAL pos, parent_type, total;
 485     PMC *_class, *mro;
 486     PMC *ns;
 487
 488     vtable = interp->vtables[type];
 489     /* multithreaded: has already mro */
 490     if (vtable->mro)
 491         return;
 492     mro = pmc_new(interp, enum_class_ResizablePMCArray);
 493     vtable->mro = mro;
 494     if (vtable->ro_variant_vtable) {
 495         vtable->ro_variant_vtable->mro = mro;
 496     }
 497     class_name = vtable->whoami;
 498     isa = vtable->isa_str;
 499     total = (INTVAL)string_length(interp, isa);
 500     for (pos = 0; ;) {
 501         INTVAL len = string_length(interp, class_name);
 502         pos += len + 1;
 503         parent_type = pmc_type(interp, class_name);
 504         if (!parent_type)   /* abstract classes don't have a vtable */
 505             break;
 506         vtable = interp->vtables[parent_type];
 507         if (!vtable->_namespace) {
 508             /* need a namespace Hash, anchor at parent, name it */
 509             ns = pmc_new(interp,
 510                     Parrot_get_ctx_HLL_type(interp, enum_class_NameSpace));
 511             vtable->_namespace = ns;
 512             /* anchor at parent, aka current_namespace, that is 'parrot' */
 513             VTABLE_set_pmc_keyed_str(interp,
 514                     CONTEXT(interp->ctx)->current_namespace,
 515                     class_name, ns);
 516         }
 517         _class = vtable->pmc_class;
 518         if (!_class) {
 519             _class = create_class_pmc(interp, parent_type);
 520         }
 521         VTABLE_push_pmc(interp, mro, _class);
 522         if (pos >= total)
 523             break;
 524         len = string_str_index(interp, isa,
 525                 CONST_STRING(interp, " "), pos);
 526         if (len == -1)
 527             len = total;
 528         class_name = string_substr(interp, isa, pos,
 529                 len - pos, NULL, 0);
 530     }
 531 }
 532
 533 /*
 534
 535 =back
 536
 537 =head2 DOD registry interface
 538
 539 =over 4
 540
 541 =item C<void
 542 dod_register_pmc(Interp* interp, PMC* pmc)>
 543
 544 Registers the PMC with the interpreter's DOD registery.
 545
 546 =cut
 547
 548 */
 549
 550 void
 551 dod_register_pmc(Interp* interp, PMC* pmc)
 552 {
 553     PMC *registry;
 554     /* Better not trigger a DOD run with a potentially unanchored PMC */
 555     Parrot_block_DOD(interp);
 556
 557     if (!interp->DOD_registry) {
 558         registry = interp->DOD_registry =
 559             pmc_new(interp, enum_class_AddrRegistry);
 560     }
 561     else
 562         registry = interp->DOD_registry;
 563     VTABLE_set_pmc_keyed(interp, registry, pmc, NULL);
 564     Parrot_unblock_DOD(interp);
 565
 566 }
 567
 568 /*
 569
 570 =item C<void
 571 dod_unregister_pmc(Interp* interp, PMC* pmc)>
 572
 573 Unregisters the PMC from the interpreter's DOD registery.
 574
 575 =cut
 576
 577 */
 578
 579 void
 580 dod_unregister_pmc(Interp* interp, PMC* pmc)
 581 {
 582     if (!interp->DOD_registry)
 583         return; /* XXX or signal exception? */
 584     VTABLE_delete_keyed(interp, interp->DOD_registry, pmc);
 585 }
 586
 587 /*
 588
 589 =back
 590
 591 =head1 SEE ALSO
 592
 593 F<include/parrot/vtable.h>.
 594
 595 C<5.1.0.14.2.20011008152120.02158148@pop.sidhe.org>
 596 (http://www.nntp.perl.org/group/perl.perl6.internals/5516).
 597
 598 =head1 HISTORY
 599
 600 Initial version by Simon on 2001.10.20.
 601
 602 =cut
 603
 604 */
 605
 606
 607 /*
 608  * Local variables:
 609  *   c-file-style: "parrot"
 610  * End:
 611  * vim: expandtab shiftwidth=4:
 612  */