[Guile-commits] GNU Guile branch, wip-case-lambda, updated. release_1-9-3-51-gcf6df9a

[Andy Wingo]

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=cf6df9a2109885a8c66b7c4231d9387f323e5e04

The branch, wip-case-lambda has been updated
       via  cf6df9a2109885a8c66b7c4231d9387f323e5e04 (commit)
      from  b9b666f860e003a28a5ab79c108bbd944c1a3602 (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 cf6df9a2109885a8c66b7c4231d9387f323e5e04
Author: Andy Wingo <address@hidden>
Date:   Sat Oct 10 17:38:15 2009 +0200

    flesh out glil support for optional and keyword arguments
    
    * libguile/vm-i-system.c (bind-rest): Renamed from push-rest-list.
      (reserve-locals): Change so that instead of reserving space for some
      additional number of locals, reserve-locals takes the absolute number
      of locals, including the arguments.
    
    * module/language/glil.scm (<glil-std-prelude>, <glil-opt-prelude>)
      (<glil-kw-prelude>): New GLIL constructs, to replace <glil-arity>.
    
    * module/language/glil/compile-assembly.scm (glil->assembly): Compile
      the new preludes. Some instructions are not yet implemented, though.
    
    * module/language/tree-il/analyze.scm (analyze-lexicals): The nlocs for
      a lambda will now be the total number of locals, including arguments.
    
    * module/language/tree-il/compile-glil.scm (flatten-lambda): Update to
      write the new prelude.
    
    * module/system/vm/program.scm (program-bindings-for-ip): If a given
      index doesn't have a binding at the ip given, don't cons it on the
      resulting list.

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

Summary of changes:
 libguile/vm-i-system.c                    |   19 ++++--
 module/language/glil.scm                  |   31 +++++++--
 module/language/glil/compile-assembly.scm |  102 +++++++++++++++++++++++------
 module/language/tree-il/analyze.scm       |    5 +-
 module/language/tree-il/compile-glil.scm  |   12 ++--
 module/system/vm/program.scm              |   16 ++---
 6 files changed, 138 insertions(+), 47 deletions(-)

diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 71d0666..b1a261a 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -500,7 +500,7 @@ VM_DEFINE_INSTRUCTION (39, assert_nargs_ge, 
"assert-nargs-ge", 2, 0, 0)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (40, push_rest_list, "push-rest-list", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (40, bind_rest, "bind-rest", 2, -1, -1)
 {
   scm_t_ptrdiff n;
   SCM rest = SCM_EOL;
@@ -515,13 +515,22 @@ VM_DEFINE_INSTRUCTION (40, push_rest_list, 
"push-rest-list", 2, -1, -1)
 
 VM_DEFINE_INSTRUCTION (41, reserve_locals, "reserve-locals", 2, -1, -1)
 {
+  SCM *old_sp;
   scm_t_int32 n;
   n = FETCH () << 8;
   n += FETCH ();
-  sp += n;
-  CHECK_OVERFLOW ();
-  while (n--)
-    sp[-n] = SCM_UNDEFINED;
+  old_sp = sp;
+  sp = (fp - 1) + n;
+
+  if (old_sp < sp)
+    {
+      CHECK_OVERFLOW ();
+      while (old_sp < sp)
+        *++old_sp = SCM_UNDEFINED;
+    }
+  else
+    NULLSTACK (old_sp - sp);
+
   NEXT;
 }
 
diff --git a/module/language/glil.scm b/module/language/glil.scm
index e8249ac..0f0e9b0 100644
--- a/module/language/glil.scm
+++ b/module/language/glil.scm
@@ -26,8 +26,17 @@
   (<glil-program> make-glil-program glil-program?
    glil-program-meta glil-program-body
    
-   <glil-arity> make-glil-arity glil-arity?
-   glil-arity-nargs glil-arity-nrest glil-arity-label
+   <glil-std-prelude> make-glil-std-prelude glil-std-prelude?
+   glil-std-prelude-nreq glil-std-prelude-nlocs glil-std-prelude-else-label
+
+   <glil-opt-prelude> make-glil-opt-prelude glil-opt-prelude?
+   glil-opt-prelude-nreq glil-opt-prelude-nopt glil-opt-prelude-rest?
+   glil-opt-prelude-nlocs glil-opt-prelude-else-label
+
+   <glil-kw-prelude> make-glil-kw-prelude glil-kw-prelude?
+   glil-kw-prelude-nreq glil-kw-prelude-nopt glil-kw-prelude-kw
+   glil-kw-prelude-allow-other-keys? glil-kw-prelude-rest?
+   glil-kw-prelude-nlocs glil-kw-prelude-else-label
 
    <glil-bind> make-glil-bind glil-bind?
    glil-bind-vars
@@ -74,7 +83,9 @@
 (define-type (<glil> #:printer print-glil)
   ;; Meta operations
   (<glil-program> meta body)
-  (<glil-arity> nargs nrest label)
+  (<glil-std-prelude> nreq nlocs else-label)
+  (<glil-opt-prelude> nreq nopt rest? nlocs else-label)
+  (<glil-kw-prelude> nreq nopt rest? kw allow-other-keys? nlocs else-label)
   (<glil-bind> vars)
   (<glil-mv-bind> vars rest)
   (<glil-unbind>)
@@ -98,7 +109,12 @@
   (pmatch x
     ((program ,meta . ,body)
      (make-glil-program meta (map parse-glil body)))
-    ((arity ,nargs ,nrest ,label) (make-glil-arity nargs nrest label))
+    ((std-prelude ,nreq ,nlocs ,else-label)
+     (make-glil-std-prelude nreq nlocs else-label))
+    ((opt-prelude ,nreq ,nopt ,rest? ,nlocs ,else-label)
+     (make-glil-opt-prelude nreq nopt rest? nlocs else-label))
+    ((kw-prelude ,nreq ,nopt ,rest? ,kw ,allow-other-keys? ,nlocs ,else-label)
+     (make-glil-kw-prelude nreq nopt rest? kw allow-other-keys? nlocs 
else-label))
     ((bind . ,vars) (make-glil-bind vars))
     ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
     ((unbind) (make-glil-unbind))
@@ -120,7 +136,12 @@
     ;; meta
     ((<glil-program> meta body)
      `(program ,meta ,@(map unparse-glil body)))
-    ((<glil-arity> nargs nrest label) `(arity ,nargs ,nrest ,label))
+    ((<glil-std-prelude> nreq nlocs else-label)
+     `(std-prelude ,nreq ,nlocs ,else-label))
+    ((<glil-opt-prelude> nreq nopt rest? nlocs else-label)
+     `(opt-prelude ,nreq ,nopt ,rest? ,nlocs ,else-label))
+    ((<glil-kw-prelude> nreq nopt rest? kw allow-other-keys? nlocs else-label)
+     `(kw-prelude ,nreq ,nopt ,rest? ,kw ,allow-other-keys? ,nlocs 
,else-label))
     ((<glil-bind> vars) `(bind ,@vars))
     ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
     ((<glil-unbind>) `(unbind))
diff --git a/module/language/glil/compile-assembly.scm 
b/module/language/glil/compile-assembly.scm
index 7a1a0a2..a4680c9 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -200,6 +200,88 @@
                   `(,@table-code
                     ,@(align-program prog (addr+ addr table-code)))))))))))))
     
+    ((<glil-std-prelude> nreq nlocs else-label)
+     (emit-code `(,(if else-label
+                       `(br-if-nargs-ne ,(quotient nreq 256)
+                                        ,(modulo nreq 256)
+                                        ,else-label)
+                       `(assert-nargs-ee ,(quotient nreq 256)
+                                         ,(modulo nreq 256)))
+                  (reserve-locals ,(quotient nlocs 256)
+                                  ,(modulo nlocs 256)))))
+
+    ((<glil-opt-prelude> nreq nopt rest? nlocs else-label)
+     (let ((bind-required
+            (if else-label
+                `((br-if-nargs-lt ,(quotient nreq 256)
+                                  ,(modulo nreq 256)
+                                  ,else-label))
+                `((assert-nargs-ge ,(quotient nreq 256)
+                                   ,(modulo nreq 256)))))
+           (bind-optionals
+            (if (zero? nopt)
+                '()
+                `((bind-optionals ,(quotient (+ nopt nreq) 256)
+                                  ,(modulo (+ nreq nopt) 256)))))
+           (bind-rest
+            (cond
+             (rest?
+              `((bind-rest ,(quotient (+ nreq nopt) 256)
+                           ,(modulo (+ nreq nopt) 256))))
+             (else
+              (if else-label
+                  `((br-if-nargs-ge ,(quotient (+ nreq nopt) 256)
+                                    ,(modulo (+ nreq nopt) 256)
+                                    ,else-label))
+                  `((assert-nargs-ee ,(quotient (+ nreq nopt) 256)
+                                     ,(modulo (+ nreq nopt) 256))))))))
+       (emit-code `(,@bind-required
+                    ,@bind-optionals
+                    ,@bind-rest
+                    (reserve-locals ,(quotient nlocs 256)
+                                    ,(modulo nlocs 256))))))
+    
+    ((<glil-kw-prelude> nreq nopt rest? kw allow-other-keys? nlocs else-label)
+     (receive (kw-idx object-alist)
+         (object-index-and-alist object-alist kw)
+       (let ((bind-required
+              (if else-label
+                  `((br-if-nargs-lt ,(quotient nreq 256)
+                                    ,(modulo nreq 256)
+                                    ,else-label))
+                  `((assert-nargs-ge ,(quotient nreq 256)
+                                     ,(modulo nreq 256)))))
+             (bind-optionals-and-shuffle
+              `((bind-optionals-and-shuffle-kwargs
+                 ,(quotient (+ nreq nopt) 256)
+                 ,(modulo (+ nreq nopt) 256)
+                 ,(quotient (apply max (+ nreq nopt) (map cdr kw)) 256)
+                 ,(modulo (apply max (+ nreq nopt) (map cdr kw)) 256))))
+             (bind-kw
+              ;; when this code gets called, all optionals are filled
+              ;; in, space has been made for kwargs, and the kwargs
+              ;; themselves have been shuffled above the slots for all
+              ;; req/opt/kwargs locals.
+              `((,(if allow-other-keys? 'bind-kwargs/aok 'bind-kwargs/no-aok)
+                 ,(quotient kw-idx 256)
+                 ,(modulo kw-idx 256)
+                 ,(quotient (+ nreq nopt) 256)
+                 ,(modulo (+ nreq nopt) 256)
+                 ,(quotient (apply max (+ nreq nopt) (map cdr kw)) 256)
+                 ,(modulo (apply max (+ nreq nopt) (map cdr kw)) 256))))
+             (bind-rest
+              (if rest?
+                  `((bind-rest ,(quotient (apply max (+ nreq nopt) (map cdr 
kw)) 256)
+                               ,(modulo (apply max (+ nreq nopt) (map cdr kw)) 
256)))
+                  '())))
+         (emit-code/object `(,@bind-required
+                             ,@bind-optionals-and-shuffle
+                             ,@bind-kw
+                             ,@bind-rest
+                             (reserve-locals ,(quotient nlocs 256)
+                                             ,(modulo nlocs 256)))
+                           object-alist))))
+    
     ((<glil-bind> vars)
      (values '()
              (open-binding bindings vars addr)
@@ -356,26 +438,6 @@
     ((<glil-branch> inst label)
      (emit-code `((,inst ,label))))
 
-    ((<glil-arity> nargs nrest label)
-     (emit-code (if label
-                    (if (zero? nrest)
-                        `((br-if-nargs-ne ,(quotient nargs 256) ,label))
-                        `(,@(if (> nargs 1)
-                                `((br-if-nargs-lt ,(quotient (1- nargs) 256)
-                                                  ,(modulo (1- nargs 256))
-                                                  ,label))
-                                '())
-                          (push-rest-list ,(quotient (1- nargs) 256))))
-                    (if (zero? nrest)
-                        `((assert-nargs-ee ,(quotient nargs 256)
-                                           ,(modulo nargs 256)))
-                        `(,@(if (> nargs 1)
-                                `((assert-nargs-ge ,(quotient (1- nargs) 256)
-                                                   ,(modulo (1- nargs) 256)))
-                                '())
-                          (push-rest-list ,(quotient (1- nargs) 256)
-                                          ,(modulo (1- nargs) 256)))))))
-    
     ;; nargs is number of stack args to insn. probably should rename.
     ((<glil-call> inst nargs)
      (if (not (instruction? inst))
diff --git a/module/language/tree-il/analyze.scm 
b/module/language/tree-il/analyze.scm
index 10c1d0b..a8f65c8 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -360,8 +360,9 @@
                                   (make-hashq
                                    x `(#t ,(hashq-ref assigned v) . ,n)))
                       (lp (if (pair? vars) (cdr vars) '()) (1+ n)))
-                    ;; allocate body, return number of additional locals
-                    (- (allocate! body x n) n))))
+                    ;; allocate body, return total number of locals
+                    ;; (including arguments)
+                    (allocate! body x n))))
              (free-addresses
               (map (lambda (v)
                      (hashq-ref (hashq-ref allocation v) proc))
diff --git a/module/language/tree-il/compile-glil.scm 
b/module/language/tree-il/compile-glil.scm
index 22adf73..cc287e9 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -203,15 +203,15 @@
           ;; write source info for proc
           (if (lambda-src x)
               (emit-code #f (make-glil-source (lambda-src x))))
-          ;; check arity, potentially consing a rest list
-          (emit-code #f (make-glil-arity nargs nrest #f))
-          ;; reserve space for locals, if necessary
-          (if (not (zero? nlocs))
-              (emit-code #f (make-glil-call 'reserve-locals nlocs)))
+          ;; the prelude, to check args & reset the stack pointer,
+          ;; allowing room for locals
+          (if (zero? nrest)
+              (emit-code #f (make-glil-std-prelude nargs nlocs #f))
+              (emit-code #f (make-glil-opt-prelude (1- nargs) 0 #t nlocs #f)))
           ;; write bindings info
           (if (not (null? ids))
               (emit-bindings #f ids vars allocation x emit-code))
-          ;; emit post-prelude label for self tail calls
+          ;; post-prelude label for self tail calls
           (if self-label
               (emit-code #f (make-glil-label self-label)))
           ;; box args if necessary
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 53f276f..9d7ac19 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -88,15 +88,13 @@
   (let lp ((in (program-bindings-by-index prog)) (out '()))
     (if (null? in)
         (reverse out)
-        (lp (cdr in)
-            (cons (let lp ((binds (car in)))
-                    (cond ((null? binds) #f)
-                          ((<= (binding:start (car binds))
-                               ip
-                               (binding:end (car binds)))
-                           (car binds))
-                          (else (lp (cdr binds)))))
-                  out)))))
+        (let find-bind ((binds (car in)))
+          (cond
+           ((null? binds)
+            (lp (cdr in) out))
+           ((<= (binding:start (car binds)) ip (binding:end (car binds)))
+            (lp (cdr in) (cons (car binds) out)))
+           (else (find-bind (cdr binds))))))))
 
 ;; returns a list of arglists
 (define (program-arglists prog)


hooks/post-receive
-- 
GNU Guile