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