src/stacks.c

   1 /*
   2 Copyright (C) 2001-2008, The Perl Foundation.
   3 $Id$
   4
   5 =head1 NAME
   6
   7 src/stacks.c - Stack handling routines for Parrot
   8
   9 =head1 DESCRIPTION
  10
  11 The stack is stored as a linked list of chunks (C<Stack_Chunk>),
  12 where each chunk has room for one entry.
  13
  14 =head2 Functions
  15
  16 =over 4
  17
  18 =cut
  19
  20 */
  21
  22 #include "parrot/parrot.h"
  23 #include "parrot/stacks.h"
  24 #include "stacks.str"
  25
  26 /* HEADERIZER HFILE: include/parrot/stacks.h */
  27
  28 /* HEADERIZER BEGIN: static */
  29 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END.  Your changes will be lost. */
  30
  31 static void run_cleanup_action(PARROT_INTERP, ARGIN(Stack_Entry_t *e))
  32         __attribute__nonnull__(1)
  33         __attribute__nonnull__(2);
  34
  35 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END.  Your changes will be lost. */
  36 /* HEADERIZER END: static */
  37
  38 /*
  39
  40 =item C<void stack_system_init>
  41
  42 Called from C<make_interpreter()> to initialize the interpreter's
  43 register stacks.
  44
  45 =cut
  46
  47 */
  48
  49 PARROT_API
  50 void
  51 stack_system_init(SHIM_INTERP)
  52 {
  53 }
  54
  55 /*
  56
  57 =item C<Stack_Chunk_t * cst_new_stack_chunk>
  58
  59 Get a new chunk either from the freelist or allocate one.
  60
  61 =cut
  62
  63 */
  64
  65 PARROT_API
  66 PARROT_WARN_UNUSED_RESULT
  67 PARROT_CANNOT_RETURN_NULL
  68 Stack_Chunk_t *
  69 cst_new_stack_chunk(PARROT_INTERP, ARGIN(const Stack_Chunk_t *chunk))
  70 {
  71     Small_Object_Pool * const pool = chunk->pool;
  72     Stack_Chunk_t * const new_chunk = (Stack_Chunk_t *)pool->get_free_object(interp, pool);
  73
  74     PObj_bufstart(new_chunk) = NULL;
  75     PObj_buflen(new_chunk)   = 0;
  76
  77     new_chunk->pool          = chunk->pool;
  78     new_chunk->name          = chunk->name;
  79
  80     return new_chunk;
  81 }
  82
  83 /*
  84
  85 =item C<Stack_Chunk_t * new_stack>
  86
  87 Create a new stack and name it. C<< stack->name >> is used for
  88 debugging/error reporting.
  89
  90 =cut
  91
  92 */
  93
  94 PARROT_API
  95 PARROT_CANNOT_RETURN_NULL
  96 PARROT_WARN_UNUSED_RESULT
  97 Stack_Chunk_t *
  98 new_stack(PARROT_INTERP, ARGIN(const char *name))
  99 {
 100     Small_Object_Pool * const pool = make_bufferlike_pool(interp, sizeof (Stack_Chunk_t));
 101     Stack_Chunk_t     * const chunk = (Stack_Chunk_t *)(pool->get_free_object)(interp, pool);
 102
 103     chunk->prev = chunk;        /* mark the top of the stack */
 104     chunk->name = name;
 105     chunk->pool = pool;         /* cache the pool pointer, for ease */
 106
 107     return chunk;
 108 }
 109
 110
 111 /*
 112
 113 =item C<void mark_stack>
 114
 115 Mark entries in a stack structure during DOD.
 116
 117 =cut
 118
 119 */
 120
 121 PARROT_API
 122 void
 123 mark_stack(PARROT_INTERP, ARGMOD(Stack_Chunk_t *chunk))
 124 {
 125     for (; ; chunk = chunk->prev) {
 126         Stack_Entry_t  *entry;
 127
 128         pobject_lives(interp, (PObj *)chunk);
 129
 130         if (chunk == chunk->prev)
 131             break;
 132
 133         entry = STACK_DATAP(chunk);
 134
 135         if (entry->entry_type == STACK_ENTRY_PMC && UVal_pmc(entry->entry))
 136             pobject_lives(interp, (PObj *)UVal_pmc(entry->entry));
 137     }
 138 }
 139
 140 /*
 141
 142 =item C<void stack_destroy>
 143
 144 stack_destroy() doesn't need to do anything, since GC does it all.
 145
 146 =cut
 147
 148 */
 149
 150 PARROT_API
 151 void
 152 stack_destroy(SHIM(Stack_Chunk_t *top))
 153 {
 154     /* GC does it all */
 155 }
 156
 157 /*
 158
 159 =item C<size_t stack_height>
 160
 161 Returns the height of the stack. The maximum "depth" is height - 1.
 162
 163 =cut
 164
 165 */
 166
 167 PARROT_API
 168 PARROT_WARN_UNUSED_RESULT
 169 size_t
 170 stack_height(SHIM_INTERP, ARGIN(const Stack_Chunk_t *chunk))
 171 {
 172     size_t height = 0;
 173
 174     for (; ; chunk = chunk->prev) {
 175         if (chunk == chunk->prev)
 176             break;
 177         ++height;
 178     }
 179
 180     return height;
 181 }
 182
 183
 184 /*
 185
 186 =item C<Stack_Entry_t * stack_entry>
 187
 188 If C<< depth >= 0 >>, return the entry at that depth from the top of the
 189 stack, with 0 being the top entry. If C<depth < 0>, then return the
 190 entry C<|depth|> entries from the bottom of the stack. Returns C<NULL>
 191 if C<|depth| > number> of entries in stack.
 192
 193 =cut
 194
 195 */
 196
 197 PARROT_API
 198 PARROT_CAN_RETURN_NULL
 199 PARROT_WARN_UNUSED_RESULT
 200 Stack_Entry_t *
 201 stack_entry(PARROT_INTERP, ARGIN(Stack_Chunk_t *stack), INTVAL depth)
 202 {
 203     Stack_Chunk_t *chunk;
 204     size_t         offset = (size_t)depth;
 205
 206     if (depth < 0)
 207         return NULL;
 208
 209     /* Start at top */
 210     chunk = stack;
 211
 212     while (offset) {
 213         if (chunk == chunk->prev)
 214             break;
 215         --offset;
 216         chunk = chunk->prev;
 217     }
 218
 219     if (chunk == chunk->prev)
 220         return NULL;
 221
 222     return STACK_DATAP(chunk);
 223 }
 224
 225 /*
 226
 227 =item C<void rotate_entries>
 228
 229 Rotate the top N entries by one.  If C<< N > 0 >>, the rotation is bubble
 230 up, so the top most element becomes the Nth element.  If C<< N < 0 >>, the
 231 rotation is bubble down, so that the Nth element becomes the top most
 232 element.
 233
 234 */
 235
 236 PARROT_API
 237 void
 238 rotate_entries(PARROT_INTERP, ARGMOD(Stack_Chunk_t **stack_p), INTVAL num_entries)
 239 {
 240     Stack_Chunk_t * const stack = *stack_p;
 241
 242     if (num_entries >= -1 && num_entries <= 1) {
 243         return;
 244     }
 245
 246     if (num_entries < 0) {
 247         INTVAL i;
 248         Stack_Entry_t temp;
 249         INTVAL depth;
 250
 251         num_entries = -num_entries;
 252         depth = num_entries - 1;
 253
 254         if (stack_height(interp, stack) < (size_t)num_entries)
 255             Parrot_ex_throw_from_c_args(interp, NULL, ERROR_STACK_SHALLOW,
 256                 "Stack too shallow!");
 257
 258         /* XXX Dereferencing stack_entry here is a cavalcade of danger */
 259         temp = *stack_entry(interp, stack, depth);
 260         for (i = depth; i > 0; i--) {
 261             *stack_entry(interp, stack, i) =
 262                 *stack_entry(interp, stack, i - 1);
 263         }
 264
 265         *stack_entry(interp, stack, 0) = temp;
 266     }
 267     else {
 268         INTVAL i;
 269         Stack_Entry_t temp;
 270         INTVAL depth = num_entries - 1;
 271
 272         if (stack_height(interp, stack) < (size_t)num_entries)
 273             Parrot_ex_throw_from_c_args(interp, NULL, ERROR_STACK_SHALLOW,
 274                 "Stack too shallow!");
 275
 276         /* XXX Dereferencing stack_entry here is a cavalcade of danger */
 277         temp = *stack_entry(interp, stack, 0);
 278
 279         for (i = 0; i < depth; i++) {
 280             *stack_entry(interp, stack, i) =
 281                 *stack_entry(interp, stack, i + 1);
 282         }
 283
 284         *stack_entry(interp, stack, depth) = temp;
 285     }
 286 }
 287
 288 /*
 289
 290 =item C<Stack_Entry_t* stack_prepare_push>
 291
 292 Return a pointer, where new entries go for push.
 293
 294 =cut
 295
 296 */
 297
 298 PARROT_API
 299 PARROT_WARN_UNUSED_RESULT
 300 PARROT_CANNOT_RETURN_NULL
 301 Stack_Entry_t*
 302 stack_prepare_push(PARROT_INTERP, ARGMOD(Stack_Chunk_t **stack_p))
 303 {
 304     Stack_Chunk_t * const chunk     = *stack_p;
 305     Stack_Chunk_t * const new_chunk = cst_new_stack_chunk(interp, chunk);
 306
 307     new_chunk->prev = chunk;
 308     *stack_p        = new_chunk;
 309
 310     return STACK_DATAP(new_chunk);
 311 }
 312
 313 /*
 314
 315 =item C<void stack_push>
 316
 317 Push something on the generic stack.
 318
 319 Note that the cleanup pointer, if non-C<NULL>, points to a routine
 320 that'll be called when the entry is removed from the stack. This is
 321 handy for those cases where you need some sort of activity to take place
 322 when an entry is removed, such as when you push a lexical lock onto the
 323 call stack, or localize (or tempify, or whatever we're calling it)
 324 variable or something.
 325
 326 */
 327
 328 PARROT_API
 329 void
 330 stack_push(PARROT_INTERP, ARGMOD(Stack_Chunk_t **stack_p),
 331            ARGIN(void *thing), Stack_entry_type type, NULLOK(Stack_cleanup_method cleanup))
 332 {
 333     Stack_Entry_t * const entry = (Stack_Entry_t *)stack_prepare_push(interp, stack_p);
 334
 335     /* Remember the type */
 336     entry->entry_type = type;
 337
 338     /* Remember the cleanup function */
 339     entry->cleanup = cleanup;
 340
 341     /* Store our thing */
 342     switch (type) {
 343         case STACK_ENTRY_MARK:
 344             UVal_int(entry->entry) = *(INTVAL *)thing;
 345             break;
 346         case STACK_ENTRY_DESTINATION:
 347             UVal_ptr(entry->entry) = thing;
 348             break;
 349         case STACK_ENTRY_ACTION:
 350         case STACK_ENTRY_PMC:
 351             UVal_pmc(entry->entry) = (PMC *)thing;
 352             break;
 353         default:
 354             Parrot_ex_throw_from_c_args(interp, NULL, ERROR_BAD_STACK_TYPE,
 355                 "Invalid Stack_Entry_type!");
 356     }
 357 }
 358
 359 /*
 360
 361 =item C<Stack_Entry_t* stack_prepare_pop>
 362
 363 Return a pointer, where new entries are popped off.
 364
 365 =cut
 366
 367 */
 368
 369 PARROT_API
 370 PARROT_WARN_UNUSED_RESULT
 371 PARROT_CANNOT_RETURN_NULL
 372 Stack_Entry_t*
 373 stack_prepare_pop(PARROT_INTERP, ARGMOD(Stack_Chunk_t **stack_p))
 374 {
 375     Stack_Chunk_t * const chunk = *stack_p;
 376
 377     /* the first entry (initial top) refers to itself */
 378     if (chunk == chunk->prev)
 379         Parrot_ex_throw_from_c_args(interp, NULL, ERROR_STACK_EMPTY,
 380             "No entries on %s Stack!", chunk->name);
 381
 382     *stack_p = chunk->prev;
 383
 384     return STACK_DATAP(chunk);
 385 }
 386
 387 /*
 388
 389 =item C<void * stack_pop>
 390
 391 Pop off an entry and return a pointer to the contents.
 392
 393 */
 394
 395 PARROT_API
 396 PARROT_CAN_RETURN_NULL
 397 void *
 398 stack_pop(PARROT_INTERP, ARGMOD(Stack_Chunk_t **stack_p),
 399           ARGOUT_NULLOK(void *where), Stack_entry_type type)
 400 {
 401     Stack_Chunk_t     *cur_chunk   = *stack_p;
 402     Stack_Entry_t * const entry    =
 403         (Stack_Entry_t *)stack_prepare_pop(interp, stack_p);
 404
 405     /* Types of 0 mean we don't care */
 406     if (type && entry->entry_type != type)
 407         Parrot_ex_throw_from_c_args(interp, NULL, ERROR_BAD_STACK_TYPE,
 408             "Wrong type on top of stack!\n");
 409
 410     /* Cleanup routine? */
 411     if (entry->cleanup != STACK_CLEANUP_NULL)
 412         (*entry->cleanup) (interp, entry);
 413
 414     /* Sometimes the caller cares what the value was */
 415     if (where) {
 416         /* Snag the value */
 417         switch (type) {
 418         case STACK_ENTRY_MARK:
 419             *(INTVAL *)where   = UVal_int(entry->entry);
 420             break;
 421         case STACK_ENTRY_DESTINATION:
 422             *(void **)where    = UVal_ptr(entry->entry);
 423             break;
 424         case STACK_ENTRY_ACTION:
 425         case STACK_ENTRY_PMC:
 426             *(PMC **)where     = UVal_pmc(entry->entry);
 427             break;
 428         default:
 429             Parrot_ex_throw_from_c_args(interp, NULL, ERROR_BAD_STACK_TYPE,
 430                 "Wrong type on top of stack!\n");
 431         }
 432     }
 433
 434     /* recycle this chunk to the free list if it's otherwise unreferenced */
 435     if (cur_chunk->refcount <= 0) {
 436         Small_Object_Pool * const pool = cur_chunk->pool;
 437
 438         pool->dod_object(interp, pool, (PObj *)cur_chunk);
 439         pool->add_free_object(interp, pool, (PObj *)cur_chunk);
 440     }
 441
 442     return where;
 443 }
 444
 445 /*
 446
 447 =item C<void * pop_dest>
 448
 449 Pop off a destination entry and return a pointer to the contents.
 450
 451 =cut
 452
 453 */
 454
 455 PARROT_API
 456 PARROT_WARN_UNUSED_RESULT
 457 PARROT_CANNOT_RETURN_NULL
 458 void *
 459 pop_dest(PARROT_INTERP)
 460 {
 461     /* We don't mind the extra call, so we do this: (previous comment
 462      * said we *do* mind, but I say let the compiler decide) */
 463     void *dest;
 464     (void)stack_pop(interp, &interp->dynamic_env,
 465                     &dest, STACK_ENTRY_DESTINATION);
 466     return dest;
 467 }
 468
 469 /*
 470
 471 =item C<void * stack_peek>
 472
 473 Peek at stack and return pointer to entry and the type of the entry.
 474
 475 =cut
 476
 477 */
 478
 479 PARROT_API
 480 PARROT_CAN_RETURN_NULL
 481 PARROT_WARN_UNUSED_RESULT
 482 void *
 483 stack_peek(PARROT_INTERP, ARGIN(Stack_Chunk_t *stack_base),
 484            ARGMOD_NULLOK(Stack_entry_type *type))
 485 {
 486     const Stack_Entry_t * const entry = stack_entry(interp, stack_base, 0);
 487     if (entry == NULL)
 488         return NULL;
 489
 490     if (type != NULL)
 491         *type = entry->entry_type;
 492
 493     if (entry->entry_type == STACK_ENTRY_DESTINATION)
 494         return UVal_ptr(entry->entry);
 495
 496     return (void *) UVal_pmc(entry->entry);
 497 }
 498
 499 /*
 500
 501 =item C<Stack_entry_type get_entry_type>
 502
 503 Returns the stack entry type of C<entry>.
 504
 505 =cut
 506
 507 */
 508
 509 PARROT_WARN_UNUSED_RESULT
 510 PARROT_PURE_FUNCTION
 511 Stack_entry_type
 512 get_entry_type(ARGIN(const Stack_Entry_t *entry))
 513 {
 514     return entry->entry_type;
 515 }
 516
 517 /*
 518
 519 =item C<void Parrot_dump_dynamic_environment>
 520
 521 Print a representation of the dynamic stack to the standard error (using
 522 C<PIO_eprintf>).  This is used only temporarily for debugging.
 523
 524 =cut
 525
 526 */
 527
 528 PARROT_API
 529 void
 530 Parrot_dump_dynamic_environment(PARROT_INTERP, ARGIN(Stack_Chunk_t *dynamic_env))
 531 {
 532     int height = (int) stack_height(interp, dynamic_env);
 533
 534     while (dynamic_env->prev != dynamic_env) {
 535         const Stack_Entry_t * const e = stack_entry(interp, dynamic_env, 0);
 536
 537         if (! e)
 538             Parrot_ex_throw_from_c_args(interp, NULL, 1, "Control stack damaged");
 539
 540         PIO_eprintf(interp, "[%4d:  chunk %p entry %p "
 541                                  "type %d cleanup %p]\n",
 542                     height, dynamic_env, e,
 543                     e->entry_type, e->cleanup);
 544         if (e->entry_type == STACK_ENTRY_PMC
 545                 || e->entry_type == STACK_ENTRY_ACTION) {
 546             PMC * const thing = UVal_pmc(e->entry);
 547
 548             PIO_eprintf(interp, "[        PMC %p type %d => %Ss]\n",
 549                         thing, thing->vtable->base_type,
 550                         VTABLE_get_string(interp, thing));
 551         }
 552         else if (e->entry_type == STACK_ENTRY_MARK) {
 553             PIO_eprintf(interp, "[        mark %d]\n",
 554                         UVal_int(e->entry));
 555         }
 556         dynamic_env = dynamic_env->prev;
 557         height--;
 558     }
 559     PIO_eprintf(interp, "[%4d:  chunk %p %s base]\n",
 560                 height, dynamic_env, dynamic_env->name);
 561 }
 562
 563
 564 /*
 565
 566 =item C<static void run_cleanup_action>
 567
 568 Runs the sub PMC from the Stack_Entry_t pointer with an INTVAL arg of 0.  Used
 569 in C<Parrot_push_action>.
 570
 571 =cut
 572
 573 */
 574
 575 static void
 576 run_cleanup_action(PARROT_INTERP, ARGIN(Stack_Entry_t *e))
 577 {
 578     /*
 579      * this is called during normal stack_pop of the control
 580      * stack - run the action subroutine with an INTVAL arg of 0
 581      */
 582     PMC * const sub = UVal_pmc(e->entry);
 583     Parrot_runops_fromc_args(interp, sub, "vI", 0);
 584 }
 585
 586 /*
 587
 588 =item C<void Parrot_push_action>
 589
 590 Pushes an action handler onto the dynamic environment.
 591
 592 =cut
 593
 594 */
 595
 596 PARROT_API
 597 void
 598 Parrot_push_action(PARROT_INTERP, ARGIN(PMC *sub))
 599 {
 600     if (!VTABLE_isa(interp, sub, CONST_STRING(interp, "Sub")))
 601         Parrot_ex_throw_from_c_args(interp, NULL, 1,
 602             "Tried to push a non Sub PMC action");
 603
 604     stack_push(interp, &interp->dynamic_env, sub,
 605                STACK_ENTRY_ACTION, run_cleanup_action);
 606 }
 607
 608 /*
 609
 610 =item C<void Parrot_push_mark>
 611
 612 Push a cleanup mark onto the dynamic environment.
 613
 614 =cut
 615
 616 */
 617
 618 PARROT_API
 619 void
 620 Parrot_push_mark(PARROT_INTERP, INTVAL mark)
 621 {
 622     stack_push(interp, &interp->dynamic_env, &mark,
 623                STACK_ENTRY_MARK, STACK_CLEANUP_NULL);
 624 }
 625
 626 /*
 627
 628 =item C<void Parrot_pop_mark>
 629
 630 Pop items off the dynamic environment up to the mark.
 631
 632 =cut
 633
 634 */
 635
 636 PARROT_API
 637 void
 638 Parrot_pop_mark(PARROT_INTERP, INTVAL mark)
 639 {
 640     do {
 641         const Stack_Entry_t * const e
 642             = stack_entry(interp, interp->dynamic_env, 0);
 643         if (!e)
 644             Parrot_ex_throw_from_c_args(interp, NULL, 1, "Mark %ld not found.",
 645                 (long)mark);
 646
 647         (void)stack_pop(interp, &interp->dynamic_env,
 648                         NULL, e->entry_type);
 649         if (e->entry_type == STACK_ENTRY_MARK) {
 650             if (UVal_int(e->entry) == mark)
 651                 return;
 652         }
 653     } while (1);
 654 }
 655
 656
 657 /*
 658
 659 =back
 660
 661 =head1 SEE ALSO
 662
 663 F<include/parrot/stacks.h> and F<include/parrot/enums.h>.
 664
 665 =cut
 666
 667 */
 668
 669
 670 /*
 671  * Local variables:
 672  *   c-file-style: "parrot"
 673  * End:
 674  * vim: expandtab shiftwidth=4:
 675  */