libguile/dynstack.c

   1 /* Copyright (C) 2012, 2013 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
  22 #ifdef HAVE_CONFIG_H
  23 # include <config.h>
  24 #endif
  25
  26 #include <assert.h>
  27
  28 #include "libguile/_scm.h"
  29 #include "libguile/control.h"
  30 #include "libguile/eval.h"
  31 #include "libguile/fluids.h"
  32 #include "libguile/dynstack.h"
  33
  34
  35 \f
  36
  37 #define PROMPT_WORDS 5
  38 #define PROMPT_KEY(top) (SCM_PACK ((top)[0]))
  39 #define PROMPT_FP(top) ((scm_t_ptrdiff) ((top)[1]))
  40 #define PROMPT_SP(top) ((scm_t_ptrdiff) ((top)[2]))
  41 #define PROMPT_IP(top) ((scm_t_uint32 *) ((top)[3]))
  42 #define PROMPT_JMPBUF(top) ((scm_i_jmp_buf *) ((top)[4]))
  43
  44 #define WINDER_WORDS 2
  45 #define WINDER_PROC(top) ((scm_t_guard) ((top)[0]))
  46 #define WINDER_DATA(top) ((void *) ((top)[1]))
  47
  48 #define DYNWIND_WORDS 2
  49 #define DYNWIND_ENTER(top) (SCM_PACK ((top)[0]))
  50 #define DYNWIND_LEAVE(top) (SCM_PACK ((top)[1]))
  51
  52 #define WITH_FLUID_WORDS 2
  53 #define WITH_FLUID_FLUID(top) (SCM_PACK ((top)[0]))
  54 #define WITH_FLUID_VALUE_BOX(top) (SCM_PACK ((top)[1]))
  55
  56
  57 \f
  58
  59 static void
  60 copy_scm_t_bits (scm_t_bits *dst, scm_t_bits *src, size_t n)
  61 {
  62   size_t i;
  63
  64   for (i = 0; i < n; i++)
  65     dst[i] = src[i];
  66 }
  67
  68 static void
  69 clear_scm_t_bits (scm_t_bits *items, size_t n)
  70 {
  71   size_t i;
  72
  73   for (i = 0; i < n; i++)
  74     items[i] = 0;
  75 }
  76
  77 /* Ensure space for N additional words.  */
  78 static void
  79 dynstack_ensure_space (scm_t_dynstack *dynstack, size_t n)
  80 {
  81   size_t capacity = SCM_DYNSTACK_CAPACITY (dynstack);
  82   size_t height = SCM_DYNSTACK_HEIGHT (dynstack);
  83
  84   n += SCM_DYNSTACK_HEADER_LEN;
  85
  86   if (capacity < height + n)
  87     {
  88       scm_t_bits *new_base;
  89
  90       while (capacity < height + n)
  91         capacity = (capacity < 4) ? 8 : (capacity * 2);
  92
  93       new_base = scm_gc_malloc (capacity * sizeof(scm_t_bits), "dynstack");
  94
  95       copy_scm_t_bits (new_base, dynstack->base, height);
  96       clear_scm_t_bits (dynstack->base, height);
  97
  98       dynstack->base = new_base;
  99       dynstack->top = new_base + height;
 100       dynstack->limit = new_base + capacity;
 101     }
 102 }
 103
 104 static inline scm_t_bits *
 105 push_dynstack_entry_unchecked (scm_t_dynstack *dynstack,
 106                                scm_t_dynstack_item_type type,
 107                                scm_t_bits flags, size_t len)
 108 {
 109   scm_t_bits *ret = dynstack->top;
 110
 111   SCM_DYNSTACK_SET_TAG (dynstack->top, SCM_MAKE_DYNSTACK_TAG (type, flags, len));
 112   dynstack->top += SCM_DYNSTACK_HEADER_LEN + len;
 113   SCM_DYNSTACK_SET_PREV_OFFSET (dynstack->top, SCM_DYNSTACK_HEADER_LEN + len);
 114
 115   return ret;
 116 }
 117
 118 static inline scm_t_bits *
 119 push_dynstack_entry (scm_t_dynstack *dynstack,
 120                      scm_t_dynstack_item_type type,
 121                      scm_t_bits flags, size_t len)
 122 {
 123   if (SCM_UNLIKELY (!SCM_DYNSTACK_HAS_SPACE (dynstack, len)))
 124     dynstack_ensure_space (dynstack, len);
 125   return push_dynstack_entry_unchecked (dynstack, type, flags, len);
 126 }
 127
 128 void
 129 scm_dynstack_push_frame (scm_t_dynstack *dynstack,
 130                          scm_t_dynstack_frame_flags flags)
 131 {
 132   push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_FRAME, flags, 0);
 133 }
 134
 135 void
 136 scm_dynstack_push_rewinder (scm_t_dynstack *dynstack,
 137                             scm_t_dynstack_winder_flags flags,
 138                             scm_t_guard proc, void *data)
 139 {
 140   scm_t_bits *words;
 141
 142   words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_REWINDER, flags,
 143                                WINDER_WORDS);
 144   words[0] = (scm_t_bits) proc;
 145   words[1] = (scm_t_bits) data;
 146 }
 147
 148 void
 149 scm_dynstack_push_unwinder (scm_t_dynstack *dynstack,
 150                             scm_t_dynstack_winder_flags flags,
 151                             scm_t_guard proc, void *data)
 152 {
 153   scm_t_bits *words;
 154
 155   words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_UNWINDER, flags,
 156                                WINDER_WORDS);
 157   words[0] = (scm_t_bits) proc;
 158   words[1] = (scm_t_bits) data;
 159 }
 160
 161 /* The fluid is stored on the stack, but the value has to be stored on the heap,
 162    so that all continuations that capture this dynamic scope capture the same
 163    binding.  */
 164 void
 165 scm_dynstack_push_fluid (scm_t_dynstack *dynstack, SCM fluid, SCM value,
 166                          SCM dynamic_state)
 167 {
 168   scm_t_bits *words;
 169   SCM value_box;
 170
 171   if (SCM_UNLIKELY (!SCM_FLUID_P (fluid)))
 172     scm_wrong_type_arg ("with-fluid*", 0, fluid);
 173
 174   value_box = scm_make_variable (value);
 175
 176   words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_WITH_FLUID, 0,
 177                                WITH_FLUID_WORDS);
 178   words[0] = SCM_UNPACK (fluid);
 179   words[1] = SCM_UNPACK (value_box);
 180
 181   /* Go ahead and swap them.  */
 182   scm_swap_fluid (fluid, value_box, dynamic_state);
 183 }
 184
 185 void
 186 scm_dynstack_push_prompt (scm_t_dynstack *dynstack,
 187                           scm_t_dynstack_prompt_flags flags,
 188                           SCM key,
 189                           scm_t_ptrdiff fp_offset, scm_t_ptrdiff sp_offset,
 190                           scm_t_uint32 *ip, scm_i_jmp_buf *registers)
 191 {
 192   scm_t_bits *words;
 193
 194   words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_PROMPT, flags,
 195                                PROMPT_WORDS);
 196   words[0] = SCM_UNPACK (key);
 197   words[1] = (scm_t_bits) fp_offset;
 198   words[2] = (scm_t_bits) sp_offset;
 199   words[3] = (scm_t_bits) ip;
 200   words[4] = (scm_t_bits) registers;
 201 }
 202
 203 void
 204 scm_dynstack_push_dynwind (scm_t_dynstack *dynstack, SCM enter, SCM leave)
 205 {
 206   scm_t_bits *words;
 207
 208   words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_DYNWIND, 0,
 209                                DYNWIND_WORDS);
 210   words[0] = SCM_UNPACK (enter);
 211   words[1] = SCM_UNPACK (leave);
 212 }
 213
 214 static inline scm_t_bits
 215 dynstack_pop (scm_t_dynstack *dynstack, scm_t_bits **words)
 216 {
 217   scm_t_bits *prev = SCM_DYNSTACK_PREV (dynstack->top);
 218   scm_t_bits tag;
 219
 220   if (SCM_UNLIKELY (!prev))
 221     abort ();
 222
 223   SCM_DYNSTACK_SET_PREV_OFFSET (dynstack->top, 0);
 224   dynstack->top = prev;
 225
 226   tag = SCM_DYNSTACK_TAG (dynstack->top);
 227   SCM_DYNSTACK_SET_TAG (dynstack->top, 0);
 228   *words = dynstack->top;
 229
 230   return tag;
 231 }
 232
 233 void
 234 scm_dynstack_pop (scm_t_dynstack *dynstack)
 235 {
 236   scm_t_bits tag, *words;
 237   tag = dynstack_pop (dynstack, &words);
 238   clear_scm_t_bits (words, SCM_DYNSTACK_TAG_LEN (tag));
 239 }
 240
 241 scm_t_dynstack *
 242 scm_dynstack_capture_all (scm_t_dynstack *dynstack)
 243 {
 244   return scm_dynstack_capture (dynstack, SCM_DYNSTACK_FIRST (dynstack));
 245 }
 246
 247 scm_t_dynstack *
 248 scm_dynstack_capture (scm_t_dynstack *dynstack, scm_t_bits *item)
 249 {
 250   char *mem;
 251   scm_t_dynstack *ret;
 252   size_t len;
 253
 254   assert (item >= SCM_DYNSTACK_FIRST (dynstack));
 255   assert (item <= dynstack->top);
 256
 257   len = dynstack->top - item + SCM_DYNSTACK_HEADER_LEN;
 258   mem = scm_gc_malloc (sizeof (*ret) + len * sizeof(scm_t_bits), "dynstack");
 259   ret = (scm_t_dynstack *) mem;
 260   ret->base = (scm_t_bits *) (mem + sizeof (*ret));
 261   ret->limit = ret->base + len;
 262   ret->top = ret->base + len;
 263
 264   copy_scm_t_bits (ret->base, item - SCM_DYNSTACK_HEADER_LEN, len);
 265   SCM_DYNSTACK_SET_PREV_OFFSET (SCM_DYNSTACK_FIRST (ret), 0);
 266
 267   return ret;
 268 }
 269
 270 void
 271 scm_dynstack_wind_1 (scm_t_dynstack *dynstack, scm_t_bits *item)
 272 {
 273   scm_t_bits tag = SCM_DYNSTACK_TAG (item);
 274   scm_t_dynstack_item_type type = SCM_DYNSTACK_TAG_TYPE (tag);
 275   scm_t_bits flags = SCM_DYNSTACK_TAG_FLAGS (tag);
 276   size_t len = SCM_DYNSTACK_TAG_LEN (tag);
 277
 278   switch (type)
 279     {
 280     case SCM_DYNSTACK_TYPE_FRAME:
 281       if (!(flags & SCM_F_DYNSTACK_FRAME_REWINDABLE))
 282         scm_misc_error ("scm_dynstack_wind_1",
 283                         "cannot invoke continuation from this context",
 284                         SCM_EOL);
 285       break;
 286
 287     case SCM_DYNSTACK_TYPE_UNWINDER:
 288       break;
 289
 290     case SCM_DYNSTACK_TYPE_REWINDER:
 291       WINDER_PROC (item) (WINDER_DATA (item));
 292       break;
 293
 294     case SCM_DYNSTACK_TYPE_WITH_FLUID:
 295       scm_swap_fluid (WITH_FLUID_FLUID (item),
 296                       WITH_FLUID_VALUE_BOX (item),
 297                       SCM_I_CURRENT_THREAD->dynamic_state);
 298       break;
 299
 300     case SCM_DYNSTACK_TYPE_PROMPT:
 301       /* see vm_reinstate_partial_continuation */
 302       break;
 303
 304     case SCM_DYNSTACK_TYPE_DYNWIND:
 305       scm_call_0 (DYNWIND_ENTER (item));
 306       break;
 307
 308     case SCM_DYNSTACK_TYPE_NONE:
 309     default:
 310       abort ();
 311     }
 312
 313   {
 314     scm_t_bits *words = push_dynstack_entry (dynstack, type, flags, len);
 315
 316     copy_scm_t_bits (words, item, len);
 317   }
 318 }
 319
 320 scm_t_bits
 321 scm_dynstack_unwind_1 (scm_t_dynstack *dynstack)
 322 {
 323   scm_t_bits tag;
 324   scm_t_bits *words;
 325   scm_t_dynstack_item_type type;
 326
 327   tag = dynstack_pop (dynstack, &words);
 328
 329   type = SCM_DYNSTACK_TAG_TYPE (tag);
 330
 331   switch (type)
 332     {
 333     case SCM_DYNSTACK_TYPE_FRAME:
 334       break;
 335
 336     case SCM_DYNSTACK_TYPE_UNWINDER:
 337       WINDER_PROC (words) (WINDER_DATA (words));
 338       clear_scm_t_bits (words, WINDER_WORDS);
 339       break;
 340
 341     case SCM_DYNSTACK_TYPE_REWINDER:
 342       clear_scm_t_bits (words, WINDER_WORDS);
 343       break;
 344
 345     case SCM_DYNSTACK_TYPE_WITH_FLUID:
 346       scm_swap_fluid (WITH_FLUID_FLUID (words),
 347                       WITH_FLUID_VALUE_BOX (words),
 348                       SCM_I_CURRENT_THREAD->dynamic_state);
 349       clear_scm_t_bits (words, WITH_FLUID_WORDS);
 350       break;
 351
 352     case SCM_DYNSTACK_TYPE_PROMPT:
 353       /* we could invalidate the prompt */
 354       clear_scm_t_bits (words, PROMPT_WORDS);
 355       break;
 356
 357     case SCM_DYNSTACK_TYPE_DYNWIND:
 358       {
 359         SCM proc = DYNWIND_LEAVE (words);
 360         clear_scm_t_bits (words, DYNWIND_WORDS);
 361         scm_call_0 (proc);
 362       }
 363       break;
 364
 365     case SCM_DYNSTACK_TYPE_NONE:
 366     default:
 367       abort ();
 368     }
 369
 370   return tag;
 371 }
 372
 373 void
 374 scm_dynstack_wind (scm_t_dynstack *dynstack, scm_t_bits *item)
 375 {
 376   for (; SCM_DYNSTACK_TAG (item); item = SCM_DYNSTACK_NEXT (item))
 377     scm_dynstack_wind_1 (dynstack, item);
 378 }
 379
 380 void
 381 scm_dynstack_unwind (scm_t_dynstack *dynstack, scm_t_bits *base)
 382 {
 383   while (dynstack->top > base)
 384     scm_dynstack_unwind_1 (dynstack);
 385 }
 386
 387 static int
 388 same_entries (scm_t_bits *walk_a, scm_t_bits *next_a,
 389               scm_t_bits *walk_b, scm_t_bits *next_b)
 390 {
 391   if (SCM_DYNSTACK_TAG (walk_a) != SCM_DYNSTACK_TAG (walk_b))
 392     return 0;
 393
 394   if (next_a - walk_a != next_b - walk_b)
 395     return 0;
 396
 397   assert (SCM_DYNSTACK_PREV_OFFSET (next_a) == next_a - walk_a);
 398   assert (SCM_DYNSTACK_PREV_OFFSET (next_b) == next_b - walk_b);
 399
 400   while (walk_a != next_a)
 401     if (*(walk_a++) != *(walk_b++))
 402       return 0;
 403
 404   return 1;
 405 }
 406
 407 static ptrdiff_t
 408 shared_prefix_length (scm_t_dynstack *a, scm_t_dynstack *b)
 409 {
 410   scm_t_bits *walk_a, *next_a, *walk_b, *next_b;
 411
 412   walk_a = SCM_DYNSTACK_FIRST (a);
 413   walk_b = SCM_DYNSTACK_FIRST (b);
 414
 415   next_a = SCM_DYNSTACK_NEXT (walk_a);
 416   next_b = SCM_DYNSTACK_NEXT (walk_b);
 417
 418   while (next_a && next_b && same_entries (walk_a, next_a, walk_b, next_b))
 419     {
 420       walk_a = next_a;
 421       walk_b = next_b;
 422
 423       next_a = SCM_DYNSTACK_NEXT (walk_a);
 424       next_b = SCM_DYNSTACK_NEXT (walk_b);
 425     }
 426
 427   return walk_a - a->base;
 428 }
 429
 430 scm_t_bits *
 431 scm_dynstack_unwind_fork (scm_t_dynstack *dynstack, scm_t_dynstack *branch)
 432 {
 433   ptrdiff_t join_height;
 434
 435   join_height = shared_prefix_length (dynstack, branch);
 436
 437   scm_dynstack_unwind (dynstack, dynstack->base + join_height);
 438
 439   return branch->base + join_height;
 440 }
 441
 442 scm_t_bits*
 443 scm_dynstack_find_prompt (scm_t_dynstack *dynstack, SCM key,
 444                           scm_t_dynstack_prompt_flags *flags,
 445                           scm_t_ptrdiff *fp_offset, scm_t_ptrdiff *sp_offset,
 446                           scm_t_uint32 **ip, scm_i_jmp_buf **registers)
 447 {
 448   scm_t_bits *walk;
 449
 450   for (walk = SCM_DYNSTACK_PREV (dynstack->top); walk;
 451        walk = SCM_DYNSTACK_PREV (walk))
 452     {
 453       scm_t_bits tag = SCM_DYNSTACK_TAG (walk);
 454
 455       if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT
 456           && scm_is_eq (PROMPT_KEY (walk), key))
 457         {
 458           if (flags)
 459             *flags = SCM_DYNSTACK_TAG_FLAGS (tag);
 460           if (fp_offset)
 461             *fp_offset = PROMPT_FP (walk);
 462           if (sp_offset)
 463             *sp_offset = PROMPT_SP (walk);
 464           if (ip)
 465             *ip = PROMPT_IP (walk);
 466           if (registers)
 467             *registers = PROMPT_JMPBUF (walk);
 468           return walk;
 469         }
 470     }
 471
 472   return NULL;
 473 }
 474
 475 void
 476 scm_dynstack_wind_prompt (scm_t_dynstack *dynstack, scm_t_bits *item,
 477                           scm_t_ptrdiff reloc, scm_i_jmp_buf *registers)
 478 {
 479   scm_t_bits tag = SCM_DYNSTACK_TAG (item);
 480
 481   if (SCM_DYNSTACK_TAG_TYPE (tag) != SCM_DYNSTACK_TYPE_PROMPT)
 482     abort ();
 483
 484   scm_dynstack_push_prompt (dynstack,
 485                             SCM_DYNSTACK_TAG_FLAGS (tag),
 486                             PROMPT_KEY (item),
 487                             PROMPT_FP (item) + reloc,
 488                             PROMPT_SP (item) + reloc,
 489                             PROMPT_IP (item),
 490                             registers);
 491 }
 492
 493 void
 494 scm_dynstack_unwind_frame (scm_t_dynstack *dynstack)
 495 {
 496   /* Unwind up to and including the next frame entry.  */
 497   while (1)
 498     {
 499       scm_t_bits tag, *words;
 500
 501       tag = dynstack_pop (dynstack, &words);
 502
 503       switch (SCM_DYNSTACK_TAG_TYPE (tag))
 504         {
 505         case SCM_DYNSTACK_TYPE_FRAME:
 506           return;
 507         case SCM_DYNSTACK_TYPE_REWINDER:
 508           clear_scm_t_bits (words, WINDER_WORDS);
 509           continue;
 510         case SCM_DYNSTACK_TYPE_UNWINDER:
 511           {
 512             scm_t_guard proc = WINDER_PROC (words);
 513             void *data = WINDER_DATA (words);
 514             clear_scm_t_bits (words, WINDER_WORDS);
 515             if (SCM_DYNSTACK_TAG_FLAGS (tag) & SCM_F_DYNSTACK_WINDER_EXPLICIT)
 516               proc (data);
 517             continue;
 518           }
 519         default:
 520           /* We should only see winders.  */
 521           abort ();
 522         }
 523     }
 524 }
 525
 526 /* This function must not allocate.  */
 527 void
 528 scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack, SCM dynamic_state)
 529 {
 530   scm_t_bits tag, *words;
 531   size_t len;
 532
 533   tag = dynstack_pop (dynstack, &words);
 534   len = SCM_DYNSTACK_TAG_LEN (tag);
 535
 536   assert (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_WITH_FLUID);
 537   assert (len == WITH_FLUID_WORDS);
 538
 539   scm_swap_fluid (WITH_FLUID_FLUID (words), WITH_FLUID_VALUE_BOX (words),
 540                   dynamic_state);
 541   clear_scm_t_bits (words, len);
 542 }
 543
 544
 545 /*
 546   Local Variables:
 547   c-file-style: "gnu"
 548   End:
 549 */