guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, master, updated. release_1-9-8-35-g9a1


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. release_1-9-8-35-g9a1c6f1
Date: Wed, 24 Feb 2010 16:45:00 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=9a1c6f1f0c6b07725a240160b79acc54303d7891

The branch, master has been updated
       via  9a1c6f1f0c6b07725a240160b79acc54303d7891 (commit)
       via  078014374c066f03975bd0ef008877c5236c75ec (commit)
       via  6d804376e94d17cf013a415c4bd98d632f7a91b9 (commit)
       via  ac644098bf1573cfbb4ee032e6cd32a23ca168b6 (commit)
      from  cee1d22c3c10b1892c82a5758ef69cd6fc9aba31 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 9a1c6f1f0c6b07725a240160b79acc54303d7891
Author: Andy Wingo <address@hidden>
Date:   Wed Feb 24 17:43:02 2010 +0100

    rewind the dynamic state when entering a partial continuation
    
    * libguile/control.c (cont_objcode):
    * libguile/vm-i-system.c (partial-cont-call):
    * libguile/vm.c (vm_reinstate_partial_continuation): Don't keep the
      "external winds" in a partial continuation, as they aren't logically
      part of the continuation. Reinstate the "internal winds" when entering
      a partial continuation. Things seem to work!

commit 078014374c066f03975bd0ef008877c5236c75ec
Author: Andy Wingo <address@hidden>
Date:   Wed Feb 24 16:56:45 2010 +0100

    partial-cont-call works
    
    * libguile/vm-i-system.c (partial-cont-call): Sync registers before
      splatting a partial continuation, and cache them back afterwards.
    
    * libguile/vm.c (vm_reinstate_partial_continuation): Actually implement,
      except dynamic-wind.

commit 6d804376e94d17cf013a415c4bd98d632f7a91b9
Author: Andy Wingo <address@hidden>
Date:   Wed Feb 24 16:56:05 2010 +0100

    record IP in partial continuations
    
    * libguile/control.c (reify_partial_continuation): Assert some
      invariants, and record the IP as the MVRA of the continuation.

commit ac644098bf1573cfbb4ee032e6cd32a23ca168b6
Author: Andy Wingo <address@hidden>
Date:   Wed Feb 24 00:32:07 2010 +0100

    ensure non-escape-only prompts have a thunk application as their body
    
    * module/language/tree-il/inline.scm (inline!): Fix indenting for
      lambda-case. In an amusing turn of events, use the inliner to
      de-inline prompt bodies, if the prompt is not escape-only.

-----------------------------------------------------------------------

Summary of changes:
 libguile/control.c                 |   24 ++++++++----
 libguile/vm-i-system.c             |   10 +++--
 libguile/vm.c                      |   59 +++++++++++++++++++++++++++++--
 module/language/tree-il/inline.scm |   68 +++++++++++++++++++++++++-----------
 4 files changed, 125 insertions(+), 36 deletions(-)

diff --git a/libguile/control.c b/libguile/control.c
index 25c9504..49a19cf 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -100,9 +100,8 @@ SCM_STATIC_OBJCODE (cont_objcode) = {
   /* 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_object_ref, 2, /* push external winds */
-  /* 6 */ scm_op_partial_cont_call, /* and go! */
-  /* 7 */ scm_op_nop, /* pad to 8 bytes */
+  /* 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
@@ -110,7 +109,7 @@ SCM_STATIC_OBJCODE (cont_objcode) = {
   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, 7, /* arity: from ip 0 to ip 
7 */
+  /* 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 */
@@ -144,15 +143,24 @@ reify_partial_continuation (SCM vm, SCM prompt, SCM 
extwinds,
   if (cookie >= 0 && SCM_PROMPT_REGISTERS (prompt)->cookie == cookie)
     flags |= SCM_F_VM_CONT_REWINDABLE;
 
-  /* NULL RA and MVRA, as those get set when the cont is reinstated */
-  vm_cont = scm_i_vm_capture_stack (SCM_PROMPT_REGISTERS (prompt)->sp,
+  /* 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, NULL,
+                                    NULL,
+                                    SCM_VM_DATA (vm)->ip,
                                     flags);
 
   ret = scm_make_program (cont_objcode,
-                          scm_vector (scm_list_3 (vm_cont, intwinds, 
extwinds)),
+                          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);
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 09293be..04ef951 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -995,12 +995,14 @@ VM_DEFINE_INSTRUCTION (89, continuation_call, 
"continuation-call", 0, -1, 0)
 
 VM_DEFINE_INSTRUCTION (94, partial_cont_call, "partial-cont-call", 0, -1, 0)
 {
-  SCM vmcont, intwinds, extwinds;
-  POP (extwinds);
+  SCM vmcont, intwinds;
   POP (intwinds);
   POP (vmcont);
-
-  vm_reinstate_partial_continuation (vm, vmcont, intwinds, extwinds);
+  SYNC_REGISTER ();
+  vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp);
+  CACHE_REGISTER ();
+  program = SCM_FRAME_PROGRAM (fp);
+  CACHE_PROGRAM ();
   NEXT;
 }
 
diff --git a/libguile/vm.c b/libguile/vm.c
index 572a710..6fecd60 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -229,10 +229,63 @@ vm_abort (SCM vm, size_t n, scm_t_int64 vm_cookie)
 }
 
 static void
-vm_reinstate_partial_continuation (SCM vm, SCM vm_cont, SCM intwinds,
-                                   SCM extwinds)
+vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
+                                   size_t n, SCM *argv)
 {
-  abort ();
+  struct scm_vm *vp;
+  struct scm_vm_cont *cp;
+  SCM *argv_copy, *base;
+  size_t i;
+
+  argv_copy = alloca (n * sizeof(SCM));
+  memcpy (argv_copy, argv, n * sizeof(SCM));
+
+  vp = SCM_VM_DATA (vm);
+  cp = SCM_VM_CONT_DATA (cont);
+  base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1;
+
+#define RELOC(scm_p) (scm_p + cp->reloc + (base - cp->stack_base))
+
+  if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size)
+    {
+      /* puts ("FIXME: Need to expand"); */
+      abort ();
+    }
+
+  memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM));
+
+  /* now relocate frame pointers */
+  {
+    SCM *fp;
+    for (fp = RELOC (cp->fp);
+         SCM_FRAME_LOWER_ADDRESS (fp) > base;
+         fp = SCM_FRAME_DYNAMIC_LINK (fp))
+      SCM_FRAME_SET_DYNAMIC_LINK (fp, RELOC (SCM_FRAME_DYNAMIC_LINK (fp)));
+  }
+
+  vp->sp = base - 1 + cp->stack_size;
+  vp->fp = RELOC (cp->fp);
+  vp->ip = cp->mvra;
+
+#undef RELOC
+
+  /* now push args. ip is in a MV context. */
+  for (i = 0; i < n; i++)
+    {
+      vp->sp++;
+      *vp->sp = argv_copy[i];
+    }
+  vp->sp++;
+  *vp->sp = scm_from_size_t (n);
+
+  /* Finally, rewind the dynamic state. */
+  {
+    long delta = 0;
+    SCM newwinds = scm_i_dynwinds ();
+    for (; scm_is_pair (intwinds); intwinds = scm_cdr (intwinds), delta--)
+      newwinds = scm_cons (scm_car (intwinds), newwinds);
+    scm_dowinds (newwinds, delta);
+  }
 }
 
 
diff --git a/module/language/tree-il/inline.scm 
b/module/language/tree-il/inline.scm
index 905622d..4e3863e 100644
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -111,28 +111,54 @@
        (if (null? vars) body x))
        
       ((<lambda-case> req opt rest kw vars body alternate)
-       (let ()
-         (define (args-compatible? args vars)
-           (let lp ((args args) (vars vars))
-             (cond
-              ((null? args) (null? vars))
-              ((null? vars) #f)
-              ((and (lexical-ref? (car args))
-                    (eq? (lexical-ref-gensym (car args)) (car vars)))
-               (lp (cdr args) (cdr vars)))
-              (else #f))))
+       (define (args-compatible? args vars)
+         (let lp ((args args) (vars vars))
+           (cond
+            ((null? args) (null? vars))
+            ((null? vars) #f)
+            ((and (lexical-ref? (car args))
+                  (eq? (lexical-ref-gensym (car args)) (car vars)))
+             (lp (cdr args) (cdr vars)))
+            (else #f))))
          
-         (and (not opt) (not kw) (not alternate)
-              (record-case body
-                ((<application> proc args)
-                 ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
-                 (and (primitive-ref? proc)
-                      (eq? (primitive-ref-name proc) '@apply)
-                      (pair? args)
-                      (lambda? (car args))
-                      (args-compatible? (cdr args) vars)
-                      (lambda-body (car args))))
-                (else #f)))))
+       (and (not opt) (not kw) (not alternate)
+            (record-case body
+              ((<application> proc args)
+               ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
+               (and (primitive-ref? proc)
+                    (eq? (primitive-ref-name proc) '@apply)
+                    (pair? args)
+                    (lambda? (car args))
+                    (args-compatible? (cdr args) vars)
+                    (lambda-body (car args))))
+              (else #f))))
+
+      ;; Actually the opposite of inlining -- if the prompt cannot be proven to
+      ;; be escape-only, ensure that its body is the application of a thunk.
+      ((<prompt> src tag body handler)
+       (define (escape-only? handler)
+         (and (pair? (lambda-case-req handler))
+              (let ((cont (car (lambda-case-vars handler))))
+                (tree-il-fold (lambda (leaf escape-only?)
+                                (and escape-only?
+                                     (not
+                                      (and (lexical-ref? leaf)
+                                           (eq? (lexical-ref-gensym leaf) 
cont)))))
+                              (lambda (down escape-only?) escape-only?)
+                              (lambda (up escape-only?) escape-only?)
+                              #t
+                              (lambda-case-body handler)))))
+       (define (make-thunk body)
+         (make-lambda #f '() (make-lambda-case #f '() #f #f #f '() '() body 
#f)))
+
+       (if (or (and (application? body)
+                    (lambda? (application-proc body))
+                    (null? (application-args body)))
+               (escape-only? handler))
+           x
+           (make-prompt src tag
+                        (make-application #f (make-thunk body) '())
+                        handler)))
       
       (else #f)))
   (post-order! inline1 x))


hooks/post-receive
-- 
GNU Guile




reply via email to

[Prev in Thread] Current Thread [Next in Thread]