src/pmc.c

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