libguile/dynstack.c

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