[Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. dce042f1f74f8ef5ca5089beb50fd7496feae5da

[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=dce042f1f74f8ef5ca5089beb50fd7496feae5da

The branch, syncase-in-boot-9 has been updated
       via  dce042f1f74f8ef5ca5089beb50fd7496feae5da (commit)
      from  112edbaea3e48e002261c72064d6602d661c3df4 (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 dce042f1f74f8ef5ca5089beb50fd7496feae5da
Author: Andy Wingo <address@hidden>
Date:   Mon May 18 01:08:34 2009 +0200

    special cases for more types of known applications
    
    * module/language/tree-il/compile-glil.scm (flatten): Handle a number of
      interesting applications, and fix a bug for calls in `drop' contexts.
    
    * module/language/tree-il/inline.scm: Define expanders for apply,
      call-with-values, call-with-current-continuation, and values.

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

Summary of changes:
 module/language/tree-il/compile-glil.scm |   78 ++++++++++++++++++++++++++---
 module/language/tree-il/inline.scm       |   15 +++++-
 2 files changed, 83 insertions(+), 10 deletions(-)

diff --git a/module/language/tree-il/compile-glil.scm 
b/module/language/tree-il/compile-glil.scm
index 23d05c3..b617bd8 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -30,10 +30,6 @@
 
 ;;; TODO:
 ;;
-;; * (address@hidden f args) -> goto/apply or similar
-;; * (address@hidden values args) -> goto/values or similar
-;; * (address@hidden prod cons) ...
-;; * (address@hidden prod cons) ...
 ;; call-with-values -> mv-bind
 ;; compile-time-environment
 ;; GOOPS' @slot-ref, @slot-set
@@ -178,8 +174,72 @@
                (lp (cdr exps))))))
 
       ((<application> src proc args)
+       ;; FIXME: need a better pattern-matcher here
        (cond
         ((and (primitive-ref? proc)
+              (eq? (primitive-ref-name proc) '@apply)
+              (>= (length args) 2))
+         (let ((proc (car args))
+               (args (cdr args)))
+           (cond
+            ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
+                  (not (eq? context 'push)))
+             ;; tail: (lambda () (apply values '(1 2)))
+             ;; drop: (lambda () (apply values '(1 2)) 3)
+             ;; push: (lambda () (list (apply values '(10 12)) 1))
+             (case context
+               ((drop) (for-each comp-drop args))
+               ((tail)
+                (for-each comp-push args)
+                (emit-code src (make-glil-call 'return/values* (length 
args))))))
+
+            (else
+             (comp-push proc)
+             (for-each comp-push args)
+             (case context
+               ((drop) (emit-code src (make-glil-call 'apply (length args)))
+                       (emit-code src (make-glil-call 'drop 1)))
+               ((tail) (emit-code src (make-glil-call 'goto/apply (length 
args))))
+               ((push) (emit-code src (make-glil-call 'apply (length 
args)))))))))
+
+        ((and (primitive-ref? proc)
+              (eq? (primitive-ref-name proc) '@call-with-values)
+              (= (length args) 2))
+        ;; CONSUMER
+         ;; PRODUCER
+         ;; (mv-call MV)
+         ;; ([tail]-call 1)
+         ;; goto POST
+         ;; MV: [tail-]call/nargs
+         ;; POST: (maybe-drop)
+         (let ((MV (make-label)) (POST (make-label))
+               (producer (car args)) (consumer (cadr args)))
+           (comp-push consumer)
+           (comp-push producer)
+           (emit-code src (make-glil-mv-call 0 MV))
+           (case context
+             ((tail) (emit-code src (make-glil-call 'goto/args 1)))
+             (else   (emit-code src (make-glil-call 'call 1))
+                     (emit-branch #f 'br POST)))
+           (emit-label MV)
+           (case context
+             ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
+             (else   (emit-code src (make-glil-call 'call/nargs 0))
+                     (emit-label POST)
+                     (if (eq? context 'drop)
+                         (emit-code #f (make-glil-call 'drop 1)))))))
+
+        ((and (primitive-ref? proc)
+              (eq? (primitive-ref-name proc) '@call-with-current-continuation)
+              (= (length args 1)))
+         (comp-push (car args))
+         (case context
+           ((tail) (emit-code src (make-glil-call 'goto/cc 1)))
+           ((push) (emit-code src (make-glil-call 'call/cc 1)))
+           ((drop) (emit-code src (make-glil-call 'call/cc 1))
+                   (emit-code src (make-glil-call 'drop 1)))))
+
+        ((and (primitive-ref? proc)
               (hash-ref *primcall-ops*
                         (cons (primitive-ref-name proc) (length args))))
          => (lambda (op)
@@ -191,10 +251,12 @@
         (else
          (comp-push proc)
          (for-each comp-push args)
-         (emit-code src (make-glil-call (case context
-                                          ((tail) 'goto/args)
-                                          (else 'call))
-                                        (length args))))))
+         (let ((len (length args)))
+           (case context
+             ((tail) (emit-code src (make-glil-call 'goto/args len)))
+             ((push) (emit-code src (make-glil-call 'call len)))
+             ((drop) (emit-code src (make-glil-call 'call len))
+                     (emit-code src (make-glil-call 'drop 1))))))))
 
       ((<conditional> src test then else)
        ;;     TEST
diff --git a/module/language/tree-il/inline.scm 
b/module/language/tree-il/inline.scm
index 0161faf..d0fa74f 100644
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -135,5 +135,16 @@
   (x y) (cons x y)
   (x y . rest) (cons x (cons* y . rest)))
 
-(define-primitive-expander acons
-  (x y z) (cons (cons x y) z))
+(define-primitive-expander acons (x y z)
+  (cons (cons x y) z))
+
+(define-primitive-expander apply (f . args)
+  (@apply f . args))
+
+(define-primitive-expander call-with-values (producer consumer)
+  (@call-with-values producer consumer))
+
+(define-primitive-expander call-with-current-continuation (proc)
+  (@call-with-current-continuation proc))
+
+(define-primitive-expander values (x) x)


hooks/post-receive
-- 
GNU Guile