[Guile-commits] GNU Guile branch, master, updated. v2.1.0-271-g33e9a90

[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=33e9a90d7b66d174c41b2cf0c8c89d4a3fa88443

The branch, master has been updated
       via  33e9a90d7b66d174c41b2cf0c8c89d4a3fa88443 (commit)
       via  8cff7f54dcdaff5a87dce5d419b15a21d5884f48 (commit)
       via  a4b64fa2465e02d623982d927fbf3eea7123679c (commit)
      from  8695854a7d0795f6a0680bbdf1fc62f2894b45aa (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 33e9a90d7b66d174c41b2cf0c8c89d4a3fa88443
Author: Andy Wingo <address@hidden>
Date:   Wed Oct 23 16:57:14 2013 +0200

    Always resolve-primitives in the root module.
    
    * module/language/tree-il/primitives.scm (resolve-primitives): If we are
      compiling in the root module, ignore local definitions.

commit 8cff7f54dcdaff5a87dce5d419b15a21d5884f48
Author: Andy Wingo <address@hidden>
Date:   Wed Oct 23 15:06:24 2013 +0200

    RTL VM: Fix LOCAL_REF, LOCAL_SET for unsigned indices
    
    * libguile/vm-engine.c (LOCAL_REF, LOCAL_SET): Fix so to work with
      unsigned 0.  Previously subtracting 1 was making the index wrap
      around.

commit a4b64fa2465e02d623982d927fbf3eea7123679c
Author: Andy Wingo <address@hidden>
Date:   Wed Oct 23 19:01:03 2013 +0200

    Optimize closures with only required and rest arguments in eval
    
    * module/ice-9/eval.scm: Pregenerate closures with rest arguments, as we
      do for fixed arguments.  This is important given the amount of (lambda
      args (apply foo args)) that we are doing lately.

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

Summary of changes:
 libguile/vm-engine.c                   |    4 +-
 module/ice-9/eval.scm                  |   51 ++++++++++++++++++++++++++++----
 module/language/tree-il/primitives.scm |   19 +++++++-----
 3 files changed, 58 insertions(+), 16 deletions(-)

diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index e2f8745..cf359c9 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -628,8 +628,8 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
   case opcode:
 #endif
 
-#define LOCAL_REF(i)           SCM_FRAME_VARIABLE (fp, (i) - 1)
-#define LOCAL_SET(i,o)         SCM_FRAME_VARIABLE (fp, (i) - 1) = o
+#define LOCAL_REF(i)           SCM_FRAME_VARIABLE ((fp - 1), i)
+#define LOCAL_SET(i,o)         SCM_FRAME_VARIABLE ((fp - 1), i) = o
 
 #define VARIABLE_REF(v)                SCM_VARIABLE_REF (v)
 #define VARIABLE_SET(v,o)      SCM_VARIABLE_SET (v, o)
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index fdf16c8..1270732 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -102,6 +102,46 @@
                                     (1- nreq)
                                     (cdr args)))))))))))))
 
+  ;; Fast case for procedures with fixed arities and a rest argument.
+  (define-syntax make-rest-closure
+    (lambda (x)
+      (define *max-static-argument-count* 3)
+      (define (make-formals n)
+        (map (lambda (i)
+               (datum->syntax
+                x
+                (string->symbol
+                 (string (integer->char (+ (char->integer #\a) i))))))
+             (iota n)))
+      (syntax-case x ()
+        ((_ eval nreq body env) (not (identifier? #'env))
+         #'(let ((e env))
+             (make-rest-closure eval nreq body e)))
+        ((_ eval nreq body env)
+         #`(case nreq
+             #,@(map (lambda (nreq)
+                       (let ((formals (make-formals nreq)))
+                         #`((#,nreq)
+                            (lambda (#,@formals . rest)
+                              (eval body
+                                    (cons* rest #,@(reverse formals) env))))))
+                     (iota *max-static-argument-count*))
+             (else
+              #,(let ((formals (make-formals *max-static-argument-count*)))
+                  #`(lambda (#,@formals . more)
+                      (let lp ((new-env (cons* #,@(reverse formals) env))
+                               (nreq (- nreq #,*max-static-argument-count*))
+                               (args more))
+                        (if (zero? nreq)
+                            (eval body (cons args new-env))
+                            (if (null? args)
+                                (scm-error 'wrong-number-of-args
+                                           "eval" "Wrong number of arguments"
+                                           '() #f)
+                                (lp (cons (car args) new-env)
+                                    (1- nreq)
+                                    (cdr args)))))))))))))
+
   (define-syntax call
     (lambda (x)
       (define *max-static-call-count* 4)
@@ -212,8 +252,9 @@
 
 (define primitive-eval
   (let ()
-    ;; We pre-generate procedures with fixed arities, up to some number of
-    ;; arguments; see make-fixed-closure above.
+    ;; We pre-generate procedures with fixed arities, up to some number
+    ;; of arguments, and some rest arities; see make-fixed-closure and
+    ;; make-rest-closure above.
 
     ;; A unique marker for unbound keywords.
     (define unbound-arg (list 'unbound-arg))
@@ -222,7 +263,7 @@
     ;; multiple arities, as with case-lambda.
     (define (make-general-closure env body nreq rest? nopt kw inits alt)
       (define alt-proc
-        (and alt                             ; (body docstring nreq ...)
+        (and alt                        ; (body docstring nreq ...)
              (let* ((body (car alt))
                     (spec (cddr alt))
                     (nreq (car spec))
@@ -413,9 +454,7 @@
                 (if (null? tail)
                     (make-fixed-closure eval nreq body (capture-env env))
                     (if (null? (cdr tail))
-                        (make-general-closure (capture-env env) body
-                                              nreq (car tail)
-                                              0 #f '() #f)
+                        (make-rest-closure eval nreq body (capture-env env))
                         (apply make-general-closure (capture-env env)
                                body nreq tail)))))
            (when docstring
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index 0fe4445..c18d2b8 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -255,14 +255,17 @@
   (define local-definitions
     (make-hash-table))
 
-  (let collect-local-definitions ((x x))
-    (record-case x
-      ((<toplevel-define> name)
-       (hashq-set! local-definitions name #t))
-      ((<seq> head tail)
-       (collect-local-definitions head)
-       (collect-local-definitions tail))
-      (else #f)))
+  ;; Assume that any definitions with primitive names in the root module
+  ;; have the same semantics as the primitives.
+  (unless (eq? mod the-root-module)
+    (let collect-local-definitions ((x x))
+      (record-case x
+        ((<toplevel-define> name)
+         (hashq-set! local-definitions name #t))
+        ((<seq> head tail)
+         (collect-local-definitions head)
+         (collect-local-definitions tail))
+        (else #f))))
   
   (post-order
    (lambda (x)


hooks/post-receive
-- 
GNU Guile