1 /* Copyright (C) 2012 Free Software Foundation, Inc.
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.
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.
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
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"
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]))
44 #define WINDER_WORDS 2
45 #define WINDER_PROC(top) ((scm_t_guard) ((top)[0]))
46 #define WINDER_DATA(top) ((void *) ((top)[1]))
48 #define DYNWIND_WORDS 2
49 #define DYNWIND_ENTER(top) (SCM_PACK ((top)[0]))
50 #define DYNWIND_LEAVE(top) (SCM_PACK ((top)[1]))
52 #define WITH_FLUIDS_FLUIDS(top) ((SCM*)((top) + 1))
53 #define WITH_FLUIDS_VALUES(top) ((SCM*)((top)[0]))
59 copy_scm_t_bits (scm_t_bits
*dst
, scm_t_bits
*src
, size_t n
)
63 for (i
= 0; i
< n
; i
++)
68 copy_scm (SCM
*dst
, SCM
*src
, size_t n
)
72 for (i
= 0; i
< n
; i
++)
77 clear_scm_t_bits (scm_t_bits
*items
, size_t n
)
81 for (i
= 0; i
< n
; i
++)
85 /* Ensure space for N additional words. */
87 dynstack_ensure_space (scm_t_dynstack
*dynstack
, size_t n
)
89 size_t capacity
= SCM_DYNSTACK_CAPACITY (dynstack
);
90 size_t height
= SCM_DYNSTACK_HEIGHT (dynstack
);
92 n
+= SCM_DYNSTACK_HEADER_LEN
;
94 if (capacity
< height
+ n
)
98 while (capacity
< height
+ n
)
99 capacity
= (capacity
< 4) ? 8 : (capacity
* 2);
101 new_base
= scm_gc_malloc (capacity
* sizeof(scm_t_bits
), "dynstack");
103 copy_scm_t_bits (new_base
, dynstack
->base
, height
);
104 clear_scm_t_bits (dynstack
->base
, height
);
106 dynstack
->base
= new_base
;
107 dynstack
->top
= new_base
+ height
;
108 dynstack
->limit
= new_base
+ capacity
;
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
)
117 scm_t_bits
*ret
= dynstack
->top
;
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
);
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
)
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
);
137 scm_dynstack_push_frame (scm_t_dynstack
*dynstack
,
138 scm_t_dynstack_frame_flags flags
)
140 push_dynstack_entry (dynstack
, SCM_DYNSTACK_TYPE_FRAME
, flags
, 0);
144 scm_dynstack_push_rewinder (scm_t_dynstack
*dynstack
,
145 scm_t_dynstack_winder_flags flags
,
146 scm_t_guard proc
, void *data
)
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
;
156 scm_dynstack_push_unwinder (scm_t_dynstack
*dynstack
,
157 scm_t_dynstack_winder_flags flags
,
158 scm_t_guard proc
, void *data
)
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
;
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. */
171 scm_dynstack_push_fluids (scm_t_dynstack
*dynstack
, size_t n
,
172 SCM
*fluids
, SCM
*values
, SCM dynamic_state
)
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
);
181 words
= push_dynstack_entry (dynstack
, SCM_DYNSTACK_TYPE_WITH_FLUIDS
,
183 words
[0] = (scm_t_bits
) heap_values
;
184 copy_scm (WITH_FLUIDS_FLUIDS (words
), fluids
, n
);
186 /* Go ahead and swap them. */
187 scm_swap_fluids (n
, WITH_FLUIDS_FLUIDS (words
), WITH_FLUIDS_VALUES (words
),
192 scm_dynstack_push_prompt (scm_t_dynstack
*dynstack
,
193 scm_t_dynstack_prompt_flags flags
,
195 SCM
*fp
, SCM
*sp
, scm_t_uint8
*ip
,
196 scm_i_jmp_buf
*registers
)
200 words
= push_dynstack_entry (dynstack
, SCM_DYNSTACK_TYPE_PROMPT
, flags
,
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
;
210 scm_dynstack_push_dynwind (scm_t_dynstack
*dynstack
, SCM enter
, SCM leave
)
214 words
= push_dynstack_entry (dynstack
, SCM_DYNSTACK_TYPE_DYNWIND
, 0, 2);
215 words
[0] = SCM_UNPACK (enter
);
216 words
[1] = SCM_UNPACK (leave
);
219 static inline scm_t_bits
220 dynstack_pop (scm_t_dynstack
*dynstack
, scm_t_bits
**words
)
222 scm_t_bits
*prev
= SCM_DYNSTACK_PREV (dynstack
->top
);
225 if (SCM_UNLIKELY (!prev
))
228 SCM_DYNSTACK_SET_PREV_OFFSET (dynstack
->top
, 0);
229 dynstack
->top
= prev
;
231 tag
= SCM_DYNSTACK_TAG (dynstack
->top
);
232 SCM_DYNSTACK_SET_TAG (dynstack
->top
, 0);
233 *words
= dynstack
->top
;
239 scm_dynstack_pop (scm_t_dynstack
*dynstack
)
241 scm_t_bits tag
, *words
;
242 tag
= dynstack_pop (dynstack
, &words
);
243 clear_scm_t_bits (words
, SCM_DYNSTACK_TAG_LEN (tag
));
247 scm_dynstack_capture_all (scm_t_dynstack
*dynstack
)
249 return scm_dynstack_capture (dynstack
, SCM_DYNSTACK_FIRST (dynstack
));
253 scm_dynstack_capture (scm_t_dynstack
*dynstack
, scm_t_bits
*item
)
259 assert (item
>= SCM_DYNSTACK_FIRST (dynstack
));
260 assert (item
<= dynstack
->top
);
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
;
269 copy_scm_t_bits (ret
->base
, item
- SCM_DYNSTACK_HEADER_LEN
, len
);
270 SCM_DYNSTACK_SET_PREV_OFFSET (SCM_DYNSTACK_FIRST (ret
), 0);
276 scm_dynstack_wind_1 (scm_t_dynstack
*dynstack
, scm_t_bits
*item
)
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
);
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",
292 case SCM_DYNSTACK_TYPE_UNWINDER
:
295 case SCM_DYNSTACK_TYPE_REWINDER
:
296 WINDER_PROC (item
) (WINDER_DATA (item
));
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
);
305 case SCM_DYNSTACK_TYPE_PROMPT
:
306 /* see vm_reinstate_partial_continuation */
309 case SCM_DYNSTACK_TYPE_DYNWIND
:
310 scm_call_0 (DYNWIND_ENTER (item
));
313 case SCM_DYNSTACK_TYPE_NONE
:
319 scm_t_bits
*words
= push_dynstack_entry (dynstack
, type
, flags
, len
);
321 copy_scm_t_bits (words
, item
, len
);
326 scm_dynstack_unwind_1 (scm_t_dynstack
*dynstack
)
330 scm_t_dynstack_item_type type
;
333 tag
= dynstack_pop (dynstack
, &words
);
335 type
= SCM_DYNSTACK_TAG_TYPE (tag
);
336 len
= SCM_DYNSTACK_TAG_LEN (tag
);
340 case SCM_DYNSTACK_TYPE_FRAME
:
343 case SCM_DYNSTACK_TYPE_UNWINDER
:
344 WINDER_PROC (words
) (WINDER_DATA (words
));
345 clear_scm_t_bits (words
, WINDER_WORDS
);
348 case SCM_DYNSTACK_TYPE_REWINDER
:
349 clear_scm_t_bits (words
, WINDER_WORDS
);
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
);
359 case SCM_DYNSTACK_TYPE_PROMPT
:
360 /* we could invalidate the prompt */
361 clear_scm_t_bits (words
, PROMPT_WORDS
);
364 case SCM_DYNSTACK_TYPE_DYNWIND
:
366 SCM proc
= DYNWIND_LEAVE (words
);
367 clear_scm_t_bits (words
, DYNWIND_WORDS
);
372 case SCM_DYNSTACK_TYPE_NONE
:
381 scm_dynstack_wind (scm_t_dynstack
*dynstack
, scm_t_bits
*item
)
383 for (; SCM_DYNSTACK_TAG (item
); item
= SCM_DYNSTACK_NEXT (item
))
384 scm_dynstack_wind_1 (dynstack
, item
);
388 scm_dynstack_unwind (scm_t_dynstack
*dynstack
, scm_t_bits
*base
)
390 while (dynstack
->top
> base
)
391 scm_dynstack_unwind_1 (dynstack
);
395 same_entries (scm_t_bits
*walk_a
, scm_t_bits
*next_a
,
396 scm_t_bits
*walk_b
, scm_t_bits
*next_b
)
398 if (SCM_DYNSTACK_TAG (walk_a
) != SCM_DYNSTACK_TAG (walk_b
))
401 if (next_a
- walk_a
!= next_b
- walk_b
)
404 assert (SCM_DYNSTACK_PREV_OFFSET (next_a
) == next_a
- walk_a
);
405 assert (SCM_DYNSTACK_PREV_OFFSET (next_b
) == next_b
- walk_b
);
407 while (walk_a
!= next_a
)
408 if (*(walk_a
++) != *(walk_b
++))
415 shared_prefix_length (scm_t_dynstack
*a
, scm_t_dynstack
*b
)
417 scm_t_bits
*walk_a
, *next_a
, *walk_b
, *next_b
;
419 walk_a
= SCM_DYNSTACK_FIRST (a
);
420 walk_b
= SCM_DYNSTACK_FIRST (b
);
422 next_a
= SCM_DYNSTACK_NEXT (walk_a
);
423 next_b
= SCM_DYNSTACK_NEXT (walk_b
);
425 while (next_a
&& next_b
&& same_entries (walk_a
, next_a
, walk_b
, next_b
))
430 next_a
= SCM_DYNSTACK_NEXT (walk_a
);
431 next_b
= SCM_DYNSTACK_NEXT (walk_b
);
434 return walk_a
- a
->base
;
438 scm_dynstack_unwind_fork (scm_t_dynstack
*dynstack
, scm_t_dynstack
*branch
)
440 ptrdiff_t join_height
;
442 join_height
= shared_prefix_length (dynstack
, branch
);
444 scm_dynstack_unwind (dynstack
, dynstack
->base
+ join_height
);
446 return branch
->base
+ join_height
;
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
)
457 for (walk
= SCM_DYNSTACK_PREV (dynstack
->top
); walk
;
458 walk
= SCM_DYNSTACK_PREV (walk
))
460 scm_t_bits tag
= SCM_DYNSTACK_TAG (walk
);
462 if (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_PROMPT
463 && scm_is_eq (PROMPT_KEY (walk
), key
))
466 *flags
= SCM_DYNSTACK_TAG_FLAGS (tag
);
468 *fp
= PROMPT_FP (walk
);
470 *sp
= PROMPT_SP (walk
);
472 *ip
= PROMPT_IP (walk
);
474 *registers
= PROMPT_JMPBUF (walk
);
483 scm_dynstack_wind_prompt (scm_t_dynstack
*dynstack
, scm_t_bits
*item
,
484 scm_t_ptrdiff reloc
, scm_i_jmp_buf
*registers
)
486 scm_t_bits tag
= SCM_DYNSTACK_TAG (item
);
488 if (SCM_DYNSTACK_TAG_TYPE (tag
) != SCM_DYNSTACK_TYPE_PROMPT
)
491 scm_dynstack_push_prompt (dynstack
,
492 SCM_DYNSTACK_TAG_FLAGS (tag
),
494 PROMPT_FP (item
) + reloc
,
495 PROMPT_SP (item
) + reloc
,
501 scm_dynstack_unwind_frame (scm_t_dynstack
*dynstack
)
503 /* Unwind up to and including the next frame entry. */
506 scm_t_bits tag
, *words
;
508 tag
= dynstack_pop (dynstack
, &words
);
510 switch (SCM_DYNSTACK_TAG_TYPE (tag
))
512 case SCM_DYNSTACK_TYPE_FRAME
:
514 case SCM_DYNSTACK_TYPE_REWINDER
:
515 clear_scm_t_bits (words
, WINDER_WORDS
);
517 case SCM_DYNSTACK_TYPE_UNWINDER
:
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
)
527 /* We should only see winders. */
533 /* This function must not allocate. */
535 scm_dynstack_unwind_fluids (scm_t_dynstack
*dynstack
, SCM dynamic_state
)
537 scm_t_bits tag
, *words
;
540 tag
= dynstack_pop (dynstack
, &words
);
541 len
= SCM_DYNSTACK_TAG_LEN (tag
);
543 assert (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_WITH_FLUIDS
);
546 scm_swap_fluids (len
- 1, WITH_FLUIDS_FLUIDS (words
),
547 WITH_FLUIDS_VALUES (words
), dynamic_state
);
548 clear_scm_t_bits (words
, len
);