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-7-32-g1bf


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. release_1-9-7-32-g1bf7849
Date: Sun, 31 Jan 2010 19:47:41 +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=1bf78495e90d65911c9e012764deab589640f883

The branch, master has been updated
       via  1bf78495e90d65911c9e012764deab589640f883 (commit)
       via  1c297a3850b0b4466e5b986168c02f455c49cb1b (commit)
       via  4f66bcdeff1f5e3d1dd44d745188b91942b04d33 (commit)
      from  17d819d4c43701e0e0e92f6c2001343d4730db83 (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 -----------------------------------------------------------------
-----------------------------------------------------------------------

Summary of changes:
 libguile/vm-engine.c                   |    6 ++
 libguile/vm-i-system.c                 |   81 +++++++++++++++++++++++
 libguile/vm.c                          |   21 ++++++
 module/language/tree-il.scm            |  111 ++++++++++++++++++++++++++++++-
 module/language/tree-il/primitives.scm |   37 +++++++++++
 5 files changed, 252 insertions(+), 4 deletions(-)

diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index c46834b..75dd613 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -214,6 +214,12 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
     /* shouldn't get here */
     goto vm_error;
 
+  vm_error_not_a_thunk:
+    SYNC_ALL ();
+    scm_wrong_type_arg_msg (FUNC_NAME, 1, finish_args, "thunk");
+    /* shouldn't get here */
+    goto vm_error;
+
   vm_error_no_values:
     err_msg  = scm_from_locale_string ("Zero values returned to single-valued 
continuation");
     finish_args = SCM_EOL;
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 8c280fd..258aa52 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1433,6 +1433,87 @@ VM_DEFINE_INSTRUCTION (82, make_symbol, "make-symbol", 
0, 1, 1)
   NEXT;
 }
 
+VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 5, 3, 0)
+{
+  scm_t_int32 offset;
+  scm_t_uint8 inline_handler_p, escape_only_p;
+  SCM k, handler, pre_unwind, jmpbuf;
+
+  inline_handler_p = FETCH ();
+  escape_only_p = FETCH ();
+  FETCH_OFFSET (offset);
+  POP (pre_unwind);
+  POP (handler);
+  POP (k);
+
+  SYNC_REGISTER ();
+  /* Push the prompt onto the dynamic stack. The setjmp itself has to be local
+     to this procedure. */
+  jmpbuf = vm_prepare_prompt_jmpbuf (vm, k, handler, pre_unwind,
+                                     inline_handler_p, escape_only_p);
+  if (VM_SETJMP (jmpbuf))
+    {
+      /* The prompt exited nonlocally. Cache the regs back from the vp, and go
+         to the handler or post-handler label. (The meaning of the label 
differs
+         depending on whether the prompt's handler is rendered inline or not.)
+         */
+      CACHE_REGISTER (); /* Really we only need SP. FP and IP should be
+                            unmodified. */
+      ip += offset;
+      NEXT;
+    }
+      
+  /* Otherwise setjmp returned for the first time, so we go to execute the
+     prompt's body. */
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (85, wind, "wind", 0, 2, 0)
+{
+  SCM wind, unwind;
+  POP (unwind);
+  POP (wind);
+  SYNC_REGISTER ();
+  /* Push wind and unwind procedures onto the dynamic stack. Note that neither
+     are actually called; the compiler should emit calls to wind and unwind for
+     the normal dynamic-wind control flow. */
+  if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (wind))))
+    {
+      finish_args = wind;
+      goto vm_error_not_a_thunk;
+    }
+  if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (unwind))))
+    {
+      finish_args = unwind;
+      goto vm_error_not_a_thunk;
+    }
+  scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ()));
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (86, throw, "throw", 1, -1, -1)
+{
+  unsigned n = FETCH ();
+  SCM k;
+  SCM args;
+  POP_LIST (n);
+  POP (args);
+  POP (k);
+  SYNC_REGISTER ();
+  vm_throw (vm, k, args);
+  /* vm_throw should not return */
+  abort ();
+}
+
+VM_DEFINE_INSTRUCTION (87, unwind, "unwind", 0, 0, 0)
+{
+  /* A normal exit from the dynamic extent of an expression. Pop the top entry
+     off of the dynamic stack. */
+  scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+  NEXT;
+}
+
+
 
 /*
 (defun renumber-ops ()
diff --git a/libguile/vm.c b/libguile/vm.c
index afa888e..4c647b0 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -171,6 +171,27 @@ vm_dispatch_hook (SCM vm, int hook_num)
 
 
 /*
+ * The dynamic stack
+ */
+static SCM
+vm_prepare_prompt_jmpbuf (SCM vm, SCM k, SCM handler, SCM pre_unwind,
+                          scm_t_uint8 inline_p, scm_t_uint8 escape_only_p)
+{
+  abort ();
+  return SCM_BOOL_F;
+}
+
+#define VM_SETJMP(jmpbuf) 0
+
+static void vm_throw (SCM vm, SCM k, SCM args) SCM_NORETURN;
+static void
+vm_throw (SCM vm, SCM k, SCM args)
+{
+  abort ();
+}
+
+
+/*
  * VM Internal functions
  */
 
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 3ac3856..445de23 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -1,4 +1,4 @@
-;;;;   Copyright (C) 2009 Free Software Foundation, Inc.
+;;;;   Copyright (C) 2009, 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
@@ -45,6 +45,9 @@
             <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars 
letrec-vals letrec-body
             <fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body
             <let-values> let-values? make-let-values let-values-src 
let-values-exp let-values-body
+            <dynamic-wind> dynamic-wind? make-dynamic-wind dynamic-wind-src 
dynamic-wind-winder dynamic-wind-body dynamic-wind-unwinder
+            <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body 
prompt-handler prompt-pre-unwind-handler 
+            <control> control? make-control control-src control-tag 
control-type control-args
 
             parse-tree-il
             unparse-tree-il
@@ -74,7 +77,10 @@
   (<let> names vars vals body)
   (<letrec> names vars vals body)
   (<fix> names vars vals body)
-  (<let-values> exp body))
+  (<let-values> exp body)
+  (<dynamic-wind> winder body unwinder)
+  (<prompt> tag body handler pre-unwind-handler)
+  (<control> tag type args))
   
 
 
@@ -165,6 +171,16 @@
      ((let-values ,exp ,body)
       (make-let-values loc (retrans exp) (retrans body)))
 
+     ((dynamic-wind ,winder ,body ,unwinder)
+      (make-dynamic-wind loc (retrans winder) (retrans body) (retrans 
unwinder)))
+     
+     ((prompt ,tag ,body ,handler ,pre-unwind-handler)
+      (make-prompt loc (retrans tag) (retrans body) (retrans handler)
+                   (and=> pre-unwind-handler retrans)))
+     
+     ((control ,tag ,type ,args)
+      (make-control loc (retrans tag) type (map retrans args)))
+
      (else
       (error "unrecognized tree-il" exp)))))
 
@@ -227,7 +243,18 @@
      `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 
     ((<let-values> exp body)
-     `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
+     `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
+
+    ((<dynamic-wind> body winder unwinder)
+     `(dynamic-wind ,(unparse-tree-il body)
+               ,(unparse-tree-il winder) ,(unparse-tree-il unwinder)))
+    
+    ((<prompt> tag body handler pre-unwind-handler)
+     `(prompt ,tag ,(unparse-tree-il body) ,(unparse-tree-il handler)
+              ,(and=> pre-unwind-handler unparse-tree-il)))
+    
+    ((<control> tag type args)
+     `(control ,(unparse-tree-il tag) ,type ,(map unparse-tree-il args)))))
 
 (define (tree-il->scheme e)
   (record-case e
@@ -299,7 +326,23 @@
 
     ((<let-values> exp body)
      `(call-with-values (lambda () ,(tree-il->scheme exp))
-        ,(tree-il->scheme (make-lambda #f '() body))))))
+        ,(tree-il->scheme (make-lambda #f '() body))))
+
+    ((<dynamic-wind> body winder unwinder)
+     `(dynamic-wind ,(unparse-tree-il winder)
+                    (lambda () ,(unparse-tree-il body))
+                    ,(unparse-tree-il unwinder)))
+    
+    ((<prompt> tag body handler pre-unwind-handler)
+     `((@ (ice-9 control) prompt) 
+       ,(tree-il->scheme tag) (lambda () ,(tree-il->scheme body))
+       ,(tree-il->scheme handler) ,(and=> pre-unwind-handler tree-il->scheme)))
+    
+
+    ((<control> tag type args)
+     (case type
+       ((throw) `(throw ,(tree-il->scheme tag) ,@(map tree-il->scheme args)))
+       (else (error "bad control type" type))))))
 
 
 (define (tree-il-fold leaf down up seed tree)
@@ -352,6 +395,20 @@ This is an implementation of `foldts' as described by Andy 
Wingo in
                                 (down tree result)))))
           ((<let-values> exp body)
            (up tree (loop body (loop exp (down tree result)))))
+          ((<dynamic-wind> body winder unwinder)
+           (up tree (loop unwinder
+                          (loop winder
+                                (loop body (down tree result))))))
+          ((<prompt> tag body handler pre-unwind-handler)
+           (up tree (loop tag
+                          (loop body
+                                (loop handler
+                                      (if pre-unwind-handler
+                                          (loop pre-unwind-handler
+                                                (down tree result))
+                                          (down tree result)))))))
+          ((<control> tag type args)
+           (up tree (loop tag (loop args (down tree result)))))
           (else
            (leaf tree result))))))
 
@@ -407,6 +464,20 @@ This is an implementation of `foldts' as described by Andy 
Wingo in
                  ((<let-values> exp body)
                   (let*-values (((seed ...) (foldts exp seed ...)))
                     (foldts body seed ...)))
+                 ((<dynamic-wind> body winder unwinder)
+                  (let*-values (((seed ...) (foldts body seed ...))
+                                ((seed ...) (foldts winder seed ...)))
+                    (foldts unwinder seed ...)))
+                 ((<prompt> tag body handler pre-unwind-handler)
+                  (let*-values (((seed ...) (foldts tag seed ...))
+                                ((seed ...) (foldts body seed ...))
+                                ((seed ...) (foldts handler seed ...)))
+                    (if pre-unwind-handler
+                        (values seed ...)
+                        (foldts pre-unwind-handler seed ...))))
+                 ((<control> tag args)
+                  (let*-values (((seed ...) (foldts tag seed ...)))
+                    (fold-values foldts args seed ...)))
                  (else
                   (values seed ...)))))
            (up tree seed ...)))))))
@@ -463,6 +534,22 @@ This is an implementation of `foldts' as described by Andy 
Wingo in
        (set! (let-values-exp x) (lp exp))
        (set! (let-values-body x) (lp body)))
       
+      ((<dynamic-wind> body winder unwinder)
+       (set! (dynamic-wind-body x) (lp body))
+       (set! (dynamic-wind-winder x) (lp winder))
+       (set! (dynamic-wind-unwinder x) (lp unwinder)))
+      
+      ((<prompt> tag body handler pre-unwind-handler)
+       (set! (prompt-tag x) (lp tag))
+       (set! (prompt-body x) (lp body))
+       (set! (prompt-handler x) (lp handler))
+       (if pre-unwind-handler
+           (set! (prompt-pre-unwind-handler x) (lp pre-unwind-handler))))
+      
+      ((<control> tag args)
+       (set! (control-tag x) (lp tag))
+       (set! (control-args x) (map lp args)))
+      
       (else #f))
     
     (or (f x) x)))
@@ -519,5 +606,21 @@ This is an implementation of `foldts' as described by Andy 
Wingo in
          (set! (let-values-exp x) (lp exp))
          (set! (let-values-body x) (lp body)))
 
+        ((<dynamic-wind> body winder unwinder)
+         (set! (dynamic-wind-body x) (lp body))
+         (set! (dynamic-wind-winder x) (lp winder))
+         (set! (dynamic-wind-unwinder x) (lp unwinder)))
+        
+        ((<prompt> tag body handler pre-unwind-handler)
+         (set! (prompt-tag x) (lp tag))
+         (set! (prompt-body x) (lp body))
+         (set! (prompt-handler x) (lp handler))
+         (if pre-unwind-handler
+             (set! (prompt-pre-unwind-handler x) (lp pre-unwind-handler))))
+        
+        ((<control> tag args)
+         (set! (control-tag x) (lp tag))
+         (set! (control-args x) (map lp args)))
+        
         (else #f))
       x)))
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index ae4d3b1..ac81232 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -33,6 +33,7 @@
     call-with-values @call-with-values
     call-with-current-continuation @call-with-current-continuation
     call/cc
+    dynamic-wind
     values
     eq? eqv? equal?
     memq memv
@@ -362,3 +363,39 @@
   (bytevector-ieee-double-native-ref vec (* i 8)))
 (define-primitive-expander f64vector-set! (vec i x)
   (bytevector-ieee-double-native-set! vec (* i 8) x))
+
+(hashq-set! *primitive-expand-table*
+            'dynamic-wind
+            (case-lambda
+              ((src pre thunk post)
+               ;; Here we will make concessions to the fact that our inliner is
+               ;; lame, and add a hack.
+               (cond
+                ((lambda? thunk)
+                 (let ((PRE (gensym " pre"))
+                       (POST (gensym " post")))
+                   (make-let
+                    src
+                    '(pre post)
+                    (list PRE POST)
+                    (list pre post)
+                    (make-dynamic-wind
+                     src
+                     (make-lexical-ref #f 'pre PRE)
+                     (make-application #f thunk '())
+                     (make-lexical-ref #f 'post POST)))))
+                (else
+                 (let ((PRE (gensym " pre"))
+                       (THUNK (gensym " thunk"))
+                       (POST (gensym " post")))
+                   (make-let
+                    src
+                    '(pre thunk post)
+                    (list PRE THUNK POST)
+                    (list pre thunk post)
+                    (make-dynamic-wind
+                     src
+                     (make-lexical-ref #f 'pre PRE)
+                     (make-application #f (make-lexical-ref #f 'thunk THUNK) 
'())
+                     (make-lexical-ref #f 'post POST)))))))
+              (else #f)))


hooks/post-receive
-- 
GNU Guile




reply via email to

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