mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-24 20:30:28 +02:00
Code Activity

compile call/cc, yee ha

Browse source 
* libguile/vm-i-system.c (call, goto/args): Add a FIXME for handling the
  case in which a call to the interpreter returns a values object.
  (call/cc, goto/cc): Flesh out, and handle full continuations (with the
  C stack also).

* module/language/scheme/translate.scm (custom-transformer-table):
  Compile call-with-current-continuation. This is necessary so that the
  called procedure is called in tail position.

* module/system/il/compile.scm (codegen): Translate apply to goto/apply,
  call/cc to goto/cc, etc when in tail position.
This commit is contained in:
Andy Wingo 2008-09-25 11:07:54 +02:00
parent f63ea2ce78
commit 76282387ea
3 changed files with 80 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

61
libguile/vm-i-system.c
View file

@ -524,6 +524,7 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
POP (args);
SYNC_REGISTER ();
*sp = scm_apply (x, args, SCM_EOL);
/* FIXME what if SCM_VALUESP(*sp) */
NEXT;
}
/*
@ -694,6 +695,7 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
POP (args);
SYNC_REGISTER ();
*sp = scm_apply (x, args, SCM_EOL);
/* FIXME what if SCM_VALUESP(*sp) */
goto vm_return;
}
@ -830,20 +832,67 @@ VM_DEFINE_INSTRUCTION (goto_apply, "goto/apply", 1, -1, 1)
goto vm_goto_args;
}
VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1, 1, 1)
VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 0, 1, 1)
{
SYNC_BEFORE_GC ();
PUSH (capture_vm_cont (vp));
int first;
SCM proc, cont;
POP (proc);
SYNC_ALL ();
cont = scm_make_continuation (&first);
if (first)
{
PUSH (proc);
PUSH (cont);
nargs = 1;
goto vm_call;
}
else if (SCM_VALUESP (cont))
{
/* multiple values returned to continuation */
SCM values;
values = scm_struct_ref (cont, SCM_INUM0);
if (SCM_NULLP (values))
goto vm_error_wrong_num_args;
/* non-tail context does not accept multiple values? */
PUSH (SCM_CAR (values));
NEXT;
}
else
{
PUSH (cont);
NEXT;
}
}
VM_DEFINE_INSTRUCTION (goto_cc, "goto/cc", 1, 1, 1)
VM_DEFINE_INSTRUCTION (goto_cc, "goto/cc", 0, 1, 1)
{
SYNC_BEFORE_GC ();
PUSH (capture_vm_cont (vp));
int first;
SCM proc, cont;
POP (proc);
SYNC_ALL ();
cont = scm_make_continuation (&first);
if (first)
{
PUSH (proc);
PUSH (cont);
nargs = 1;
goto vm_goto_args;
}
else if (SCM_VALUESP (cont))
{
/* multiple values returned to continuation */
SCM values;
values = scm_struct_ref (cont, SCM_INUM0);
nvalues = scm_ilength (values);
while (!SCM_NULLP (values))
PUSH (SCM_CAR (values));
goto vm_return_values;
}
else
{
PUSH (cont);
goto vm_return;
}
}
VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)

11
module/language/scheme/translate.scm
View file

@ -331,6 +331,17 @@
((,producer ,consumer)
(make-ghil-mv-call e l (retrans producer) (retrans consumer))))
;; FIXME: not hygienic, relies on @call-with-current-continuation
;; not being shadowed
(call-with-current-continuation
((,proc)
(retrans `(@call-with-current-continuation ,proc)))
(else #f))
(@call-with-current-continuation
((,proc)
(make-ghil-inline e l 'call/cc (list (retrans proc)))))
(receive
((,formals ,producer-exp . ,body)
;; Lovely, self-referential usage. Not strictly necessary, the

10
module/system/il/compile.scm
View file

@ -331,10 +331,16 @@
((<ghil-inline> env loc inline args)
;; ARGS...
;; (INST NARGS)
;; FIXME: translate between call and goto/args, etc
(let ((tail-table '((call . goto/args)
(apply . goto/apply)
(call/cc . goto/cc))))
(cond ((and tail (assq-ref tail-table inline))
=> (lambda (tail-inst)
(push-call! loc tail-inst args)))
(else
(push-call! loc inline args)
(maybe-drop)
(maybe-return))
(maybe-return)))))
((<ghil-values> env loc values)
(cond (tail ;; (lambda () (values 1 2))