[bpt/guile.git] / libguile / control.c

/* Copyright (C) 2010  Free Software Foundation, Inc.
 * 
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#if HAVE_CONFIG_H
#  include <config.h>
#endif

#include "libguile/_scm.h"
#include "libguile/control.h"
#include "libguile/objcodes.h"
#include "libguile/instructions.h"
#include "libguile/vm.h"

\f

SCM
scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p,
                   scm_t_int64 vm_cookie)
{
  scm_t_bits tag;
  SCM ret;
  struct scm_prompt_registers *regs;

  tag = scm_tc7_prompt;
  if (escape_only_p)
    tag |= SCM_F_PROMPT_ESCAPE;
  ret = scm_words (tag, 5);

  regs = scm_gc_malloc_pointerless (sizeof (*regs), "prompt registers");
  regs->fp = SCM_VM_DATA (vm)->fp;
  regs->sp = SCM_VM_DATA (vm)->sp;
  regs->ip = SCM_VM_DATA (vm)->ip;
  regs->cookie = vm_cookie;

  SCM_SET_CELL_OBJECT (ret, 1, k);
  SCM_SET_CELL_WORD (ret, 2, (scm_t_bits)regs);
  SCM_SET_CELL_OBJECT (ret, 3, scm_i_dynwinds ());

  return ret;
}

#ifdef WORDS_BIGENDIAN
#define OBJCODE_HEADER(main,meta) 0, 0, 0, main, 0, 0, 0, meta+8
#define META_HEADER(meta)         0, 0, 0, meta, 0, 0, 0, 0
#else
#define OBJCODE_HEADER(main,meta) main, 0, 0, 0, meta+8, 0, 0, 0
#define META_HEADER(meta)         meta, 0, 0, 0, 0,      0, 0, 0
#endif

#define ROUND_UP(len,align) (((len-1)|(align-1))+1)
#define ALIGN_PTR(type,p,align) (type*)(ROUND_UP (((scm_t_bits)p), align))

#ifdef SCM_ALIGNED
#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
static const type sym[]
#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)\
static SCM_ALIGNED (alignment) const type sym[]
#else
#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
static type *sym
#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)                  \
SCM_SNARF_INIT(sym = scm_malloc (sizeof(sym##__unaligned) + alignment - 1); \
               sym = ALIGN_PTR (type, sym, alignment);                  \
               memcpy (sym, sym##__unaligned, sizeof(sym##__unaligned));) \
static type *sym = NULL;                                                \
static const type sym##__unaligned[]
#endif

#define STATIC_OBJCODE_TAG                                      \
  SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))

#define SCM_STATIC_OBJCODE(sym)                                         \
  SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode);      \
  SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = {            \
    { STATIC_OBJCODE_TAG, SCM_PACK (sym##__bytecode) },                 \
    { SCM_BOOL_F, SCM_PACK (0) }                                        \
  };                                                                    \
  static const SCM sym = SCM_PACK (sym##__cells);                       \
  SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)

  
SCM_STATIC_OBJCODE (cont_objcode) = {
  /* Like in continuations.c, but with partial-cont-call. */
  OBJCODE_HEADER (8, 19),
  /* leave args on the stack */
  /* 0 */ scm_op_object_ref, 0, /* push scm_vm_cont object */
  /* 2 */ scm_op_object_ref, 1, /* push internal winds */
  /* 4 */ scm_op_partial_cont_call, /* and go! */
  /* 5 */ scm_op_nop, scm_op_nop, scm_op_nop, /* pad to 8 bytes */
  /* 8 */

  /* We could put some meta-info to say that this proc is a continuation. Not sure
     how to do that, though. */
  META_HEADER (19),
  /* 0 */ scm_op_make_eol, /* bindings */
  /* 1 */ scm_op_make_eol, /* sources */
  /* 2 */ scm_op_make_int8, 0, scm_op_make_int8, 5, /* arity: from ip 0 to ip 7 */
  /* 6 */ scm_op_make_int8_0, /* the arity is 0 required args */
  /* 7 */ scm_op_make_int8_0, /* 0 optionals */
  /* 8 */ scm_op_make_true, /* and a rest arg */
  /* 9 */ scm_op_list, 0, 5, /* make a list of those 5 vals */
  /* 12 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */
  /* 15 */ scm_op_list, 0, 3, /* pack bindings, sources, and arities into list */
  /* 18 */ scm_op_return /* and return */
  /* 19 */
};


static SCM
reify_partial_continuation (SCM vm, SCM prompt, SCM extwinds,
                            scm_t_int64 cookie)
{
  SCM vm_cont, dynwinds, intwinds = SCM_EOL, ret;
  scm_t_uint32 flags;

  /* No need to reify if the continuation is never referenced in the handler. */
  if (SCM_PROMPT_ESCAPE_P (prompt))
    return SCM_BOOL_F;

  dynwinds = scm_i_dynwinds ();
  while (!scm_is_eq (dynwinds, extwinds))
    {
      intwinds = scm_cons (scm_car (dynwinds), intwinds);
      dynwinds = scm_cdr (dynwinds);
    }

  flags = SCM_F_VM_CONT_PARTIAL;
  if (cookie >= 0 && SCM_PROMPT_REGISTERS (prompt)->cookie == cookie)
    flags |= SCM_F_VM_CONT_REWINDABLE;

  /* Since non-escape continuations should begin with a thunk application, the
     first bit of the stack should be a frame, with the saved fp equal to the fp
     that was current when the prompt was made. */
  if ((SCM*)(SCM_PROMPT_REGISTERS (prompt)->sp[1])
      != SCM_PROMPT_REGISTERS (prompt)->fp)
    abort ();

  /* Capture from the top of the thunk application frame up to the end. Set an
     MVRA only, as the post-abort code is in an MV context. */
  vm_cont = scm_i_vm_capture_stack (SCM_PROMPT_REGISTERS (prompt)->sp + 4,
                                    SCM_VM_DATA (vm)->fp,
                                    SCM_VM_DATA (vm)->sp,
                                    NULL,
                                    SCM_VM_DATA (vm)->ip,
                                    flags);

  ret = scm_make_program (cont_objcode,
                          scm_vector (scm_list_2 (vm_cont, intwinds)),
                          SCM_BOOL_F);
  SCM_SET_CELL_WORD_0 (ret,
                       SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_CONTINUATION);
  return ret;
}

SCM
scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv, scm_t_int64 cookie)
{
  SCM cont, winds, prompt = SCM_BOOL_F;
  long delta;
  size_t i;

  /* Search the wind list for an appropriate prompt.
     "Waiter, please bring us the wind list." */
  for (winds = scm_i_dynwinds (), delta = 0;
       scm_is_pair (winds);
       winds = SCM_CDR (winds), delta++)
    {
      SCM elt = SCM_CAR (winds);
      if (SCM_PROMPT_P (elt) && scm_is_eq (SCM_PROMPT_TAG (elt), tag))
        {
          prompt = elt;
          break;
        }
    }
  
  /* If we didn't find anything, print a message and abort the process
     right here.  If you don't want this, establish a catch-all around
     any code that might throw up. */
  if (scm_is_false (prompt))
    {
      /* FIXME: jump to default */
      /* scm_handle_by_message (NULL, key, args); */
      abort ();
    }

  cont = reify_partial_continuation (vm, prompt, winds, cookie);

  /* Unwind once more, beyond the prompt. */
  winds = SCM_CDR (winds), delta++;
  
  /* Unwind */
  scm_dowinds (winds, delta);

  /* Restore VM regs */
  SCM_VM_DATA (vm)->fp = SCM_PROMPT_REGISTERS (prompt)->fp;
  SCM_VM_DATA (vm)->sp = SCM_PROMPT_REGISTERS (prompt)->sp;
  SCM_VM_DATA (vm)->ip = SCM_PROMPT_REGISTERS (prompt)->ip;

  /* Since we're jumping down, we should always have enough space */
  if (SCM_VM_DATA (vm)->sp + n + 1 >= SCM_VM_DATA (vm)->stack_limit)
    abort ();

  /* Push vals */
  *(++(SCM_VM_DATA (vm)->sp)) = cont;
  for (i = 0; i < n; i++)
    *(++(SCM_VM_DATA (vm)->sp)) = argv[i];
  *(++(SCM_VM_DATA (vm)->sp)) = scm_from_size_t (n+1); /* +1 for continuation */

  /* Jump! */
  SCM_I_LONGJMP (SCM_PROMPT_REGISTERS (prompt)->regs, 1);

  /* Shouldn't get here */
  abort ();
}

SCM_DEFINE (scm_at_abort, "@abort", 2, 0, 0, (SCM tag, SCM args),
            "Abort to the nearest prompt with tag @var{tag}.")
#define FUNC_NAME s_scm_at_abort
{
  SCM *argv;
  size_t i, n;

  SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2, args, n);
  argv = alloca (sizeof (SCM)*n);
  for (i = 0; i < n; i++, args = scm_cdr (args))
    argv[i] = scm_car (args);

  scm_c_abort (scm_the_vm (), tag, n, argv, -1);

  /* Oh, what, you're still here? The abort must have been reinstated. Actually,
     that's quite impossible, given that we're already in C-land here, so...
     abort! */

  abort ();
}
#undef FUNC_NAME

void scm_init_control (void)
{
#include "control.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/
Commit	Line	Data
b9c100d0 AW	1	/* Copyright (C) 2010 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	#if HAVE_CONFIG_H
	20	# include <config.h>
	21	#endif
	22
	23	#include "libguile/_scm.h"
	24	#include "libguile/control.h"
cee1d22c AW	25	#include "libguile/objcodes.h"
cee1d22c AW	26	#include "libguile/instructions.h"
adaf86ec	27	#include "libguile/vm.h"
b9c100d0 AW	28
	29	\f
	30
adaf86ec	31	SCM
2d026f04 AW	32	scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p,
2d026f04 AW	33	scm_t_int64 vm_cookie)
adaf86ec AW	34	{
	35	scm_t_bits tag;
	36	SCM ret;
	37	struct scm_prompt_registers *regs;
	38
	39	tag = scm_tc7_prompt;
adaf86ec AW	40	if (escape_only_p)
adaf86ec AW	41	tag \|= SCM_F_PROMPT_ESCAPE;
07a0c7d5	42	ret = scm_words (tag, 5);
adaf86ec AW	43
	44	regs = scm_gc_malloc_pointerless (sizeof (*regs), "prompt registers");
	45	regs->fp = SCM_VM_DATA (vm)->fp;
	46	regs->sp = SCM_VM_DATA (vm)->sp;
	47	regs->ip = SCM_VM_DATA (vm)->ip;
2d026f04	48	regs->cookie = vm_cookie;
adaf86ec AW	49
	50	SCM_SET_CELL_OBJECT (ret, 1, k);
	51	SCM_SET_CELL_WORD (ret, 2, (scm_t_bits)regs);
	52	SCM_SET_CELL_OBJECT (ret, 3, scm_i_dynwinds ());
adaf86ec AW	53
	54	return ret;
	55	}
	56
cee1d22c AW	57	#ifdef WORDS_BIGENDIAN
	58	#define OBJCODE_HEADER(main,meta) 0, 0, 0, main, 0, 0, 0, meta+8
	59	#define META_HEADER(meta) 0, 0, 0, meta, 0, 0, 0, 0
	60	#else
	61	#define OBJCODE_HEADER(main,meta) main, 0, 0, 0, meta+8, 0, 0, 0
	62	#define META_HEADER(meta) meta, 0, 0, 0, 0, 0, 0, 0
	63	#endif
	64
	65	#define ROUND_UP(len,align) (((len-1)\|(align-1))+1)
	66	#define ALIGN_PTR(type,p,align) (type*)(ROUND_UP (((scm_t_bits)p), align))
	67
	68	#ifdef SCM_ALIGNED
	69	#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
	70	static const type sym[]
	71	#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)\
	72	static SCM_ALIGNED (alignment) const type sym[]
	73	#else
	74	#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
	75	static type *sym
	76	#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym) \
	77	SCM_SNARF_INIT(sym = scm_malloc (sizeof(sym##__unaligned) + alignment - 1); \
	78	sym = ALIGN_PTR (type, sym, alignment); \
	79	memcpy (sym, sym##__unaligned, sizeof(sym##__unaligned));) \
	80	static type *sym = NULL; \
	81	static const type sym##__unaligned[]
	82	#endif
	83
	84	#define STATIC_OBJCODE_TAG \
	85	SCM_PACK (scm_tc7_objcode \| (SCM_F_OBJCODE_IS_STATIC << 8))
	86
	87	#define SCM_STATIC_OBJCODE(sym) \
	88	SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode); \
	89	SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = { \
	90	{ STATIC_OBJCODE_TAG, SCM_PACK (sym##__bytecode) }, \
	91	{ SCM_BOOL_F, SCM_PACK (0) } \
	92	}; \
	93	static const SCM sym = SCM_PACK (sym##__cells); \
	94	SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)
	95
	96
	97	SCM_STATIC_OBJCODE (cont_objcode) = {
	98	/* Like in continuations.c, but with partial-cont-call. */
	99	OBJCODE_HEADER (8, 19),
	100	/* leave args on the stack */
	101	/* 0 / scm_op_object_ref, 0, / push scm_vm_cont object */
	102	/* 2 / scm_op_object_ref, 1, / push internal winds */
9a1c6f1f AW	103	/* 4 / scm_op_partial_cont_call, / and go! */
9a1c6f1f AW	104	/* 5 / scm_op_nop, scm_op_nop, scm_op_nop, / pad to 8 bytes */
cee1d22c AW	105	/* 8 */
	106
	107	/* We could put some meta-info to say that this proc is a continuation. Not sure
	108	how to do that, though. */
	109	META_HEADER (19),
	110	/* 0 / scm_op_make_eol, / bindings */
	111	/* 1 / scm_op_make_eol, / sources */
9a1c6f1f	112	/* 2 / scm_op_make_int8, 0, scm_op_make_int8, 5, / arity: from ip 0 to ip 7 */
cee1d22c AW	113	/* 6 / scm_op_make_int8_0, / the arity is 0 required args */
	114	/* 7 / scm_op_make_int8_0, / 0 optionals */
	115	/* 8 / scm_op_make_true, / and a rest arg */
	116	/* 9 / scm_op_list, 0, 5, / make a list of those 5 vals */
	117	/* 12 / scm_op_list, 0, 1, / and the arities will be a list of that one list */
	118	/* 15 / scm_op_list, 0, 3, / pack bindings, sources, and arities into list */
	119	/* 18 / scm_op_return / and return */
	120	/* 19 */
	121	};
	122
	123
	124	static SCM
	125	reify_partial_continuation (SCM vm, SCM prompt, SCM extwinds,
	126	scm_t_int64 cookie)
	127	{
	128	SCM vm_cont, dynwinds, intwinds = SCM_EOL, ret;
	129	scm_t_uint32 flags;
	130
	131	/* No need to reify if the continuation is never referenced in the handler. */
	132	if (SCM_PROMPT_ESCAPE_P (prompt))
	133	return SCM_BOOL_F;
	134
	135	dynwinds = scm_i_dynwinds ();
	136	while (!scm_is_eq (dynwinds, extwinds))
	137	{
	138	intwinds = scm_cons (scm_car (dynwinds), intwinds);
	139	dynwinds = scm_cdr (dynwinds);
	140	}
	141
	142	flags = SCM_F_VM_CONT_PARTIAL;
	143	if (cookie >= 0 && SCM_PROMPT_REGISTERS (prompt)->cookie == cookie)
	144	flags \|= SCM_F_VM_CONT_REWINDABLE;
	145
6d804376 AW	146	/* Since non-escape continuations should begin with a thunk application, the
	147	first bit of the stack should be a frame, with the saved fp equal to the fp
	148	that was current when the prompt was made. */
	149	if ((SCM*)(SCM_PROMPT_REGISTERS (prompt)->sp[1])
	150	!= SCM_PROMPT_REGISTERS (prompt)->fp)
	151	abort ();
	152
	153	/* Capture from the top of the thunk application frame up to the end. Set an
	154	MVRA only, as the post-abort code is in an MV context. */
	155	vm_cont = scm_i_vm_capture_stack (SCM_PROMPT_REGISTERS (prompt)->sp + 4,
cee1d22c AW	156	SCM_VM_DATA (vm)->fp,
cee1d22c AW	157	SCM_VM_DATA (vm)->sp,
6d804376 AW	158	NULL,
6d804376 AW	159	SCM_VM_DATA (vm)->ip,
cee1d22c AW	160	flags);
	161
	162	ret = scm_make_program (cont_objcode,
9a1c6f1f	163	scm_vector (scm_list_2 (vm_cont, intwinds)),
cee1d22c AW	164	SCM_BOOL_F);
	165	SCM_SET_CELL_WORD_0 (ret,
	166	SCM_CELL_WORD_0 (ret) \| SCM_F_PROGRAM_IS_CONTINUATION);
	167	return ret;
	168	}
	169
eaefabee	170	SCM
cee1d22c	171	scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv, scm_t_int64 cookie)
eaefabee	172	{
cee1d22c	173	SCM cont, winds, prompt = SCM_BOOL_F;
eaefabee AW	174	long delta;
	175	size_t i;
	176
	177	/* Search the wind list for an appropriate prompt.
	178	"Waiter, please bring us the wind list." */
	179	for (winds = scm_i_dynwinds (), delta = 0;
	180	scm_is_pair (winds);
	181	winds = SCM_CDR (winds), delta++)
	182	{
	183	SCM elt = SCM_CAR (winds);
	184	if (SCM_PROMPT_P (elt) && scm_is_eq (SCM_PROMPT_TAG (elt), tag))
	185	{
	186	prompt = elt;
	187	break;
	188	}
	189	}
	190
	191	/* If we didn't find anything, print a message and abort the process
	192	right here. If you don't want this, establish a catch-all around
	193	any code that might throw up. */
	194	if (scm_is_false (prompt))
	195	{
	196	/* FIXME: jump to default */
	197	/* scm_handle_by_message (NULL, key, args); */
	198	abort ();
	199	}
	200
cee1d22c AW	201	cont = reify_partial_continuation (vm, prompt, winds, cookie);
cee1d22c AW	202
eaefabee AW	203	/* Unwind once more, beyond the prompt. */
	204	winds = SCM_CDR (winds), delta++;
	205
	206	/* Unwind */
	207	scm_dowinds (winds, delta);
	208
	209	/* Restore VM regs */
	210	SCM_VM_DATA (vm)->fp = SCM_PROMPT_REGISTERS (prompt)->fp;
	211	SCM_VM_DATA (vm)->sp = SCM_PROMPT_REGISTERS (prompt)->sp;
	212	SCM_VM_DATA (vm)->ip = SCM_PROMPT_REGISTERS (prompt)->ip;
	213
	214	/* Since we're jumping down, we should always have enough space */
	215	if (SCM_VM_DATA (vm)->sp + n + 1 >= SCM_VM_DATA (vm)->stack_limit)
	216	abort ();
	217
	218	/* Push vals */
cee1d22c	219	*(++(SCM_VM_DATA (vm)->sp)) = cont;
eaefabee AW	220	for (i = 0; i < n; i++)
	221	*(++(SCM_VM_DATA (vm)->sp)) = argv[i];
	222	(++(SCM_VM_DATA (vm)->sp)) = scm_from_size_t (n+1); / +1 for continuation */
	223
	224	/* Jump! */
	225	SCM_I_LONGJMP (SCM_PROMPT_REGISTERS (prompt)->regs, 1);
	226
	227	/* Shouldn't get here */
	228	abort ();
	229	}
adaf86ec	230
2d026f04	231	SCM_DEFINE (scm_at_abort, "@abort", 2, 0, 0, (SCM tag, SCM args),
747022e4	232	"Abort to the nearest prompt with tag @var{tag}.")
2d026f04	233	#define FUNC_NAME s_scm_at_abort
b9c100d0	234	{
747022e4 AW	235	SCM *argv;
	236	size_t i, n;
	237
	238	SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2, args, n);
	239	argv = alloca (sizeof (SCM)*n);
	240	for (i = 0; i < n; i++, args = scm_cdr (args))
	241	argv[i] = scm_car (args);
	242
cee1d22c	243	scm_c_abort (scm_the_vm (), tag, n, argv, -1);
747022e4	244
2d026f04 AW	245	/* Oh, what, you're still here? The abort must have been reinstated. Actually,
	246	that's quite impossible, given that we're already in C-land here, so...
	247	abort! */
	248
	249	abort ();
b9c100d0	250	}
747022e4	251	#undef FUNC_NAME
b9c100d0	252
747022e4	253	void scm_init_control (void)
b9c100d0	254	{
747022e4	255	#include "control.x"
b9c100d0 AW	256	}
	257
	258	/*
	259	Local Variables:
	260	c-file-style: "gnu"
	261	End:
	262	*/