/* Continuations and dynamic-wind.
 */

#include "scheme.h"

/* The C library version of longjmp on the VAX unwinds the stack.
 * As Jump_Cont below installs a new stack before calling longjmp,
 * the standard version cannot be used.  The following simplistic
 * version of setjmp/longjmp is used instead:
 */

#if defined(vax) || defined(__vax__)
  __asm__("    .globl  _setjmp");
  __asm__("_setjmp:");
  __asm__("    .word   0");
  __asm__("    movl    4(ap),r0");
  __asm__("    movq    r2,(r0)+");
  __asm__("    movq    r4,(r0)+");
  __asm__("    movq    r6,(r0)+");
  __asm__("    movq    r8,(r0)+");
  __asm__("    movq    r10,(r0)+");
  __asm__("    movl    fp,(r0)+");
  __asm__("    movq    4(fp),(r0)+");
  __asm__("    movq    12(fp),(r0)+");
  __asm__("    clrl    r0");
  __asm__("    ret");

  __asm__("    .globl  _longjmp");
  __asm__("_longjmp:");
  __asm__("    .word   0");
  __asm__("    movl    4(ap),r0");
  __asm__("    movq    (r0)+,r2");
  __asm__("    movq    (r0)+,r4");
  __asm__("    movq    (r0)+,r6");
  __asm__("    movq    (r0)+,r8");
  __asm__("    movq    (r0)+,r10");
  __asm__("    movl    (r0)+,r1");
  __asm__("    movq    (r0)+,4(r1)");
  __asm__("    movq    (r0)+,12(r1)");
  __asm__("    movl    8(ap),r0");
  __asm__("    movl    r1,fp");
  __asm__("    ret");
#endif

WIND *First_Wind, *Last_Wind;

static Object Cont_Value;
#ifndef USE_ALLOCA
static Object Cont_GCsave;
#endif

/* Stack_Size returns the current stack size relative to stkbase.
 * It works independent of the direction into which the stack grows
 * (the stack grows upwards on HP-PA based machines and Pyramids).
 */
int Stack_Size () {
    char foo;

    return &foo < stkbase ? stkbase-&foo : &foo-stkbase;
}

Grow_Stack (cp, val) struct S_Control *cp; Object val; {
    char buf[100];

    /* Prevent the optimizer from optimizing buf away:
     */
    bzero (buf, 100);

    Jump_Cont (cp, val);
}

Jump_Cont (cp, val) struct S_Control *cp; Object val; {
    static struct S_Control *p;
    register char *from, *to;
    register i;
    char foo;
    
#if defined(sparc) || defined(__sparc__)
    __asm__("t 0x3");   /* Flush register window */
#endif
    /* Reinstall the saved stack contents; take stack direction
     * into account.  cp must be put into a static variable, as
     * variables living on the stack cannot be referenced any
     * longer after the new stack has been installed:
     */
    p = cp;
    Cont_Value = val;
    if (&foo < stkbase) {
	if (stkbase - &foo < p->size) Grow_Stack (cp, val);
	to = stkbase - p->size;
    } else {
	if (stkbase + p->size > &foo) Grow_Stack (cp, val);
	to = stkbase;
    }
    from = p->stack;
    for (i = p->size; i > 0; i--)
	*to++ = *from++;
    longjmp (p->j, 1);
}

#ifndef USE_ALLOCA
void Terminate_Cont (cont) Object cont; {
    Free_Mem_Nodes (CONTROL(cont)->memlist);
}
#endif

Object P_Control_Pointp (x) Object x; {
    return TYPE(x) == T_Control_Point ? True : False;
}

Object P_Call_CC (proc) Object proc; {
    register t;

    t = TYPE(proc);
    if (t != T_Primitive && t != T_Compound && t != T_Control_Point)
	Wrong_Type_Combination (proc, "procedure");
    return Internal_Call_CC (0, proc);
}

Object Internal_Call_CC (from_dump, proc) int from_dump; Object proc; {
    Object control, ret, gcsave;
    register struct S_Control *cp;
    register char *p, *to;
    register size;
    GC_Node3;
    char foo;

    control = gcsave = Null;
    GC_Link3 (proc, control, gcsave);
#ifndef USE_ALLOCA
    gcsave = Save_GC_Nodes ();
#endif

    size = Stack_Size ();
    size = (size + 7) & ~7;
    control = Alloc_Object (size + sizeof (struct S_Control) - 1,
	T_Control_Point, 0);
    cp = CONTROL(control);
    cp->env = The_Environment;
    cp->gclist = GC_List;
    cp->firstwind = First_Wind;
    cp->lastwind = Last_Wind;
    cp->tailcall = Tail_Call;
    cp->size = size;
    cp->memsave = Null;
    cp->gcsave = gcsave;
#if defined(sparc) || defined(__sparc__)
    __asm__("t 0x3");   /* Flush register window */
#endif
    /* Save the current stack contents; take stack direction
     * into account.  delta holds the number of bytes by which
     * the stack contents has been moved in memory (it is required
     * to access variables on the saved stack later):
     */
    p = &foo < stkbase ? stkbase - cp->size : stkbase;
    to = cp->stack;
    bcopy (p, to, cp->size);
    cp->delta = to - p;
#ifndef USE_ALLOCA
    Register_Terminate (control, Terminate_Cont);
    Save_Mem_Nodes (control);
#endif
    if (setjmp (CONTROL(control)->j) != 0) {
#ifndef USE_ALLOCA
	Restore_GC_Nodes (Cont_GCsave);
#endif
	Enable_Interrupts;
	return Cont_Value;
    }
    if (from_dump) {
#ifdef CAN_DUMP
	Dump_Control_Point = control;
#endif
	ret = False;
    } else {
	control = Cons (control, Null);
	ret = Funcall (proc, control, 0);
    }
    GC_Unlink;
    return ret;
}

Funcall_Control_Point (control, argl, eval) Object control, argl; {
    Object val, len, x;
    register struct S_Control *cp;
    register WIND *wp, *p;
    register delta = 0;
    GC_Node4;

    if (GC_In_Progress)
	Fatal_Error ("jumping out of GC");
    val = Null;
    GC_Link4 (argl, control, val, x);
    len = P_Length (argl);
    if (FIXNUM(len) != 1)
	Primitive_Error ("control point expects one argument");
    val = Car (argl);
    if (eval)
	val = Eval (val);

    delta = CONTROL(control)->delta;
    wp = CONTROL(control)->lastwind;
    p = (WIND *)NORM(wp);
    x = wp ? p->inout : Null;
    for (wp = Last_Wind; wp && !EQ(wp->inout,x); wp = wp->prev)
	Do_Wind (Cdr (wp->inout));

    for (wp = CONTROL(control)->firstwind; wp; ) {
	delta = CONTROL(control)->delta;
	p = (WIND *)NORM(wp);
	if (First_Wind && EQ(p->inout,First_Wind->inout))
	    break;
	wp = p->next;
	Do_Wind (Car (p->inout));
    }
    GC_Unlink;
    cp = CONTROL(control);
    Switch_Environment (cp->env);
    GC_List = cp->gclist;
#ifndef USE_ALLOCA
    Restore_Mem_Nodes (control);
    Cont_GCsave = CONTROL(control)->gcsave;
#endif
    First_Wind = cp->firstwind;
    Last_Wind = cp->lastwind;
    Tail_Call = cp->tailcall;
    Jump_Cont (cp, val);
    /*NOTREACHED*/
}

Do_Wind (w) Object w; {
    Object oldenv, b, tmp;

    if (TYPE(w) == T_Vector) {          /* fluid-let */
	oldenv = The_Environment;
	Switch_Environment (VECTOR(w)->data[1]);
	b = Lookup_Symbol (VECTOR(w)->data[0], 0);
	if (Nullp (b))
	    Panic ("fluid-let");
	tmp = VECTOR(w)->data[2];
	VECTOR(w)->data[2] = Cdr (b);
	Cdr (b) = tmp;
	SYMBOL(Car (b))->value = tmp;
	VECTOR(w)->data[1] = oldenv;
	Switch_Environment (oldenv);
    } else {                            /* dynamic-wind */
	(void)Funcall (w, Null, 0);
    }
}

Add_Wind (w, in, out) register WIND *w; Object in, out; {
    Object inout;
    GC_Node2;

    GC_Link2 (in, out);
    inout = Cons (in, out);
    w->inout = inout;
    w->next = 0;
    if (First_Wind == 0)
	First_Wind = w;
    else
	Last_Wind->next = w;
    w->prev = Last_Wind;
    Last_Wind = w;
    GC_Unlink;
}

Object P_Dynamic_Wind (in, body, out) Object in, body, out; {
    WIND w, *first = First_Wind;
    Object ret;
    GC_Node4;

    Check_Procedure (in);
    Check_Procedure (body);
    Check_Procedure (out);
    ret = Null;
    GC_Link4 (in, body, out, ret);
    Add_Wind (&w, in, out);
    (void)Funcall (in, Null, 0);
    ret = Funcall (body, Null, 0);
    (void)Funcall (out, Null, 0);
    if (Last_Wind = w.prev)
	Last_Wind->next = 0;
    First_Wind = first;
    GC_Unlink;
    return ret;
}

Object P_Control_Point_Env (c) Object c; {
    Check_Type (c, T_Control_Point);
    return CONTROL(c)->env;
}
