1 /* Copyright (C) 2012, 2013 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_uint32 *) ((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_FLUID_WORDS 2
53 #define WITH_FLUID_FLUID(top) (SCM_PACK ((top)[0]))
54 #define WITH_FLUID_VALUE_BOX(top) (SCM_PACK ((top)[1]))
60 copy_scm_t_bits (scm_t_bits
*dst
, scm_t_bits
*src
, size_t n
)
64 for (i
= 0; i
< n
; i
++)
69 clear_scm_t_bits (scm_t_bits
*items
, size_t n
)
73 for (i
= 0; i
< n
; i
++)
77 /* Ensure space for N additional words. */
79 dynstack_ensure_space (scm_t_dynstack
*dynstack
, size_t n
)
81 size_t capacity
= SCM_DYNSTACK_CAPACITY (dynstack
);
82 size_t height
= SCM_DYNSTACK_HEIGHT (dynstack
);
84 n
+= SCM_DYNSTACK_HEADER_LEN
;
86 if (capacity
< height
+ n
)
90 while (capacity
< height
+ n
)
91 capacity
= (capacity
< 4) ? 8 : (capacity
* 2);
93 new_base
= scm_gc_malloc (capacity
* sizeof(scm_t_bits
), "dynstack");
95 copy_scm_t_bits (new_base
, dynstack
->base
, height
);
96 clear_scm_t_bits (dynstack
->base
, height
);
98 dynstack
->base
= new_base
;
99 dynstack
->top
= new_base
+ height
;
100 dynstack
->limit
= new_base
+ capacity
;
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
)
109 scm_t_bits
*ret
= dynstack
->top
;
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
);
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
)
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
);
129 scm_dynstack_push_frame (scm_t_dynstack
*dynstack
,
130 scm_t_dynstack_frame_flags flags
)
132 push_dynstack_entry (dynstack
, SCM_DYNSTACK_TYPE_FRAME
, flags
, 0);
136 scm_dynstack_push_rewinder (scm_t_dynstack
*dynstack
,
137 scm_t_dynstack_winder_flags flags
,
138 scm_t_guard proc
, void *data
)
142 words
= push_dynstack_entry (dynstack
, SCM_DYNSTACK_TYPE_REWINDER
, flags
,
144 words
[0] = (scm_t_bits
) proc
;
145 words
[1] = (scm_t_bits
) data
;
149 scm_dynstack_push_unwinder (scm_t_dynstack
*dynstack
,
150 scm_t_dynstack_winder_flags flags
,
151 scm_t_guard proc
, void *data
)
155 words
= push_dynstack_entry (dynstack
, SCM_DYNSTACK_TYPE_UNWINDER
, flags
,
157 words
[0] = (scm_t_bits
) proc
;
158 words
[1] = (scm_t_bits
) data
;
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
165 scm_dynstack_push_fluid (scm_t_dynstack
*dynstack
, SCM fluid
, SCM value
,
171 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
)))
172 scm_wrong_type_arg ("with-fluid*", 0, fluid
);
174 value_box
= scm_make_variable (value
);
176 words
= push_dynstack_entry (dynstack
, SCM_DYNSTACK_TYPE_WITH_FLUID
, 0,
178 words
[0] = SCM_UNPACK (fluid
);
179 words
[1] = SCM_UNPACK (value_box
);
181 /* Go ahead and swap them. */
182 scm_swap_fluid (fluid
, value_box
, dynamic_state
);
186 scm_dynstack_push_prompt (scm_t_dynstack
*dynstack
,
187 scm_t_dynstack_prompt_flags flags
,
189 SCM
*fp
, SCM
*sp
, scm_t_uint32
*ip
,
190 scm_i_jmp_buf
*registers
)
194 words
= push_dynstack_entry (dynstack
, SCM_DYNSTACK_TYPE_PROMPT
, flags
,
196 words
[0] = SCM_UNPACK (key
);
197 words
[1] = (scm_t_bits
) fp
;
198 words
[2] = (scm_t_bits
) sp
;
199 words
[3] = (scm_t_bits
) ip
;
200 words
[4] = (scm_t_bits
) registers
;
204 scm_dynstack_push_dynwind (scm_t_dynstack
*dynstack
, SCM enter
, SCM leave
)
208 words
= push_dynstack_entry (dynstack
, SCM_DYNSTACK_TYPE_DYNWIND
, 0,
210 words
[0] = SCM_UNPACK (enter
);
211 words
[1] = SCM_UNPACK (leave
);
214 static inline scm_t_bits
215 dynstack_pop (scm_t_dynstack
*dynstack
, scm_t_bits
**words
)
217 scm_t_bits
*prev
= SCM_DYNSTACK_PREV (dynstack
->top
);
220 if (SCM_UNLIKELY (!prev
))
223 SCM_DYNSTACK_SET_PREV_OFFSET (dynstack
->top
, 0);
224 dynstack
->top
= prev
;
226 tag
= SCM_DYNSTACK_TAG (dynstack
->top
);
227 SCM_DYNSTACK_SET_TAG (dynstack
->top
, 0);
228 *words
= dynstack
->top
;
234 scm_dynstack_pop (scm_t_dynstack
*dynstack
)
236 scm_t_bits tag
, *words
;
237 tag
= dynstack_pop (dynstack
, &words
);
238 clear_scm_t_bits (words
, SCM_DYNSTACK_TAG_LEN (tag
));
242 scm_dynstack_capture_all (scm_t_dynstack
*dynstack
)
244 return scm_dynstack_capture (dynstack
, SCM_DYNSTACK_FIRST (dynstack
));
248 scm_dynstack_capture (scm_t_dynstack
*dynstack
, scm_t_bits
*item
)
254 assert (item
>= SCM_DYNSTACK_FIRST (dynstack
));
255 assert (item
<= dynstack
->top
);
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
;
264 copy_scm_t_bits (ret
->base
, item
- SCM_DYNSTACK_HEADER_LEN
, len
);
265 SCM_DYNSTACK_SET_PREV_OFFSET (SCM_DYNSTACK_FIRST (ret
), 0);
271 scm_dynstack_wind_1 (scm_t_dynstack
*dynstack
, scm_t_bits
*item
)
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
);
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",
287 case SCM_DYNSTACK_TYPE_UNWINDER
:
290 case SCM_DYNSTACK_TYPE_REWINDER
:
291 WINDER_PROC (item
) (WINDER_DATA (item
));
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
);
300 case SCM_DYNSTACK_TYPE_PROMPT
:
301 /* see vm_reinstate_partial_continuation */
304 case SCM_DYNSTACK_TYPE_DYNWIND
:
305 scm_call_0 (DYNWIND_ENTER (item
));
308 case SCM_DYNSTACK_TYPE_NONE
:
314 scm_t_bits
*words
= push_dynstack_entry (dynstack
, type
, flags
, len
);
316 copy_scm_t_bits (words
, item
, len
);
321 scm_dynstack_unwind_1 (scm_t_dynstack
*dynstack
)
325 scm_t_dynstack_item_type type
;
327 tag
= dynstack_pop (dynstack
, &words
);
329 type
= SCM_DYNSTACK_TAG_TYPE (tag
);
333 case SCM_DYNSTACK_TYPE_FRAME
:
336 case SCM_DYNSTACK_TYPE_UNWINDER
:
337 WINDER_PROC (words
) (WINDER_DATA (words
));
338 clear_scm_t_bits (words
, WINDER_WORDS
);
341 case SCM_DYNSTACK_TYPE_REWINDER
:
342 clear_scm_t_bits (words
, WINDER_WORDS
);
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
);
352 case SCM_DYNSTACK_TYPE_PROMPT
:
353 /* we could invalidate the prompt */
354 clear_scm_t_bits (words
, PROMPT_WORDS
);
357 case SCM_DYNSTACK_TYPE_DYNWIND
:
359 SCM proc
= DYNWIND_LEAVE (words
);
360 clear_scm_t_bits (words
, DYNWIND_WORDS
);
365 case SCM_DYNSTACK_TYPE_NONE
:
374 scm_dynstack_wind (scm_t_dynstack
*dynstack
, scm_t_bits
*item
)
376 for (; SCM_DYNSTACK_TAG (item
); item
= SCM_DYNSTACK_NEXT (item
))
377 scm_dynstack_wind_1 (dynstack
, item
);
381 scm_dynstack_unwind (scm_t_dynstack
*dynstack
, scm_t_bits
*base
)
383 while (dynstack
->top
> base
)
384 scm_dynstack_unwind_1 (dynstack
);
388 same_entries (scm_t_bits
*walk_a
, scm_t_bits
*next_a
,
389 scm_t_bits
*walk_b
, scm_t_bits
*next_b
)
391 if (SCM_DYNSTACK_TAG (walk_a
) != SCM_DYNSTACK_TAG (walk_b
))
394 if (next_a
- walk_a
!= next_b
- walk_b
)
397 assert (SCM_DYNSTACK_PREV_OFFSET (next_a
) == next_a
- walk_a
);
398 assert (SCM_DYNSTACK_PREV_OFFSET (next_b
) == next_b
- walk_b
);
400 while (walk_a
!= next_a
)
401 if (*(walk_a
++) != *(walk_b
++))
408 shared_prefix_length (scm_t_dynstack
*a
, scm_t_dynstack
*b
)
410 scm_t_bits
*walk_a
, *next_a
, *walk_b
, *next_b
;
412 walk_a
= SCM_DYNSTACK_FIRST (a
);
413 walk_b
= SCM_DYNSTACK_FIRST (b
);
415 next_a
= SCM_DYNSTACK_NEXT (walk_a
);
416 next_b
= SCM_DYNSTACK_NEXT (walk_b
);
418 while (next_a
&& next_b
&& same_entries (walk_a
, next_a
, walk_b
, next_b
))
423 next_a
= SCM_DYNSTACK_NEXT (walk_a
);
424 next_b
= SCM_DYNSTACK_NEXT (walk_b
);
427 return walk_a
- a
->base
;
431 scm_dynstack_unwind_fork (scm_t_dynstack
*dynstack
, scm_t_dynstack
*branch
)
433 ptrdiff_t join_height
;
435 join_height
= shared_prefix_length (dynstack
, branch
);
437 scm_dynstack_unwind (dynstack
, dynstack
->base
+ join_height
);
439 return branch
->base
+ join_height
;
443 scm_dynstack_find_prompt (scm_t_dynstack
*dynstack
, SCM key
,
444 scm_t_dynstack_prompt_flags
*flags
,
445 SCM
**fp
, SCM
**sp
, scm_t_uint32
**ip
,
446 scm_i_jmp_buf
**registers
)
450 for (walk
= SCM_DYNSTACK_PREV (dynstack
->top
); walk
;
451 walk
= SCM_DYNSTACK_PREV (walk
))
453 scm_t_bits tag
= SCM_DYNSTACK_TAG (walk
);
455 if (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_PROMPT
456 && scm_is_eq (PROMPT_KEY (walk
), key
))
459 *flags
= SCM_DYNSTACK_TAG_FLAGS (tag
);
461 *fp
= PROMPT_FP (walk
);
463 *sp
= PROMPT_SP (walk
);
465 *ip
= PROMPT_IP (walk
);
467 *registers
= PROMPT_JMPBUF (walk
);
476 scm_dynstack_wind_prompt (scm_t_dynstack
*dynstack
, scm_t_bits
*item
,
477 scm_t_ptrdiff reloc
, scm_i_jmp_buf
*registers
)
479 scm_t_bits tag
= SCM_DYNSTACK_TAG (item
);
481 if (SCM_DYNSTACK_TAG_TYPE (tag
) != SCM_DYNSTACK_TYPE_PROMPT
)
484 scm_dynstack_push_prompt (dynstack
,
485 SCM_DYNSTACK_TAG_FLAGS (tag
),
487 PROMPT_FP (item
) + reloc
,
488 PROMPT_SP (item
) + reloc
,
494 scm_dynstack_unwind_frame (scm_t_dynstack
*dynstack
)
496 /* Unwind up to and including the next frame entry. */
499 scm_t_bits tag
, *words
;
501 tag
= dynstack_pop (dynstack
, &words
);
503 switch (SCM_DYNSTACK_TAG_TYPE (tag
))
505 case SCM_DYNSTACK_TYPE_FRAME
:
507 case SCM_DYNSTACK_TYPE_REWINDER
:
508 clear_scm_t_bits (words
, WINDER_WORDS
);
510 case SCM_DYNSTACK_TYPE_UNWINDER
:
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
)
520 /* We should only see winders. */
526 /* This function must not allocate. */
528 scm_dynstack_unwind_fluid (scm_t_dynstack
*dynstack
, SCM dynamic_state
)
530 scm_t_bits tag
, *words
;
533 tag
= dynstack_pop (dynstack
, &words
);
534 len
= SCM_DYNSTACK_TAG_LEN (tag
);
536 assert (SCM_DYNSTACK_TAG_TYPE (tag
) == SCM_DYNSTACK_TYPE_WITH_FLUID
);
537 assert (len
== WITH_FLUID_WORDS
);
539 scm_swap_fluid (WITH_FLUID_FLUID (words
), WITH_FLUID_VALUE_BOX (words
),
541 clear_scm_t_bits (words
, len
);