X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/bfe35b90ff0c7f78335e70bdb26ea3466f6e98d9..26d148066f9cb20e395a7dc4fefdf2e2ef0b2fb0:/module/language/tree-il/compile-glil.scm

diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 31e9a70b5..1b6fea69c 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -1,6 +1,6 @@
 ;;; TREE-IL -> GLIL compiler
 
-;; Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001,2008,2009,2010,2011,2012,2013 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
@@ -110,6 +110,7 @@
    ((list? . 1) . list?)
    ((symbol? . 1) . symbol?)
    ((vector? . 1) . vector?)
+   ((nil? . 1) . nil?)
    (list . list)
    (vector . vector)
    ((class-of . 1) . class-of)
@@ -343,9 +344,20 @@
          (for-each comp-push args)
          (let ((len (length args)))
            (case context
-             ((tail) (emit-code src (make-glil-call 'tail-call len)))
-             ((push) (emit-code src (make-glil-call 'call len))
+             ((tail) (if (<= len #xff)
+                         (emit-code src (make-glil-call 'tail-call len))
+                         (begin
+                           (comp-push (make-const #f len))
+                           (emit-code src (make-glil-call 'tail-call/nargs 0)))))
+             ((push) (if (<= len #xff)
+                         (emit-code src (make-glil-call 'call len))
+                         (begin
+                           (comp-push (make-const #f len))
+                           (emit-code src (make-glil-call 'call/nargs 0))))
                      (maybe-emit-return))
+             ;; FIXME: mv-call doesn't have a /nargs variant, so it is
+             ;; limited to 255 args.  Can work around it with a
+             ;; trampoline and tail-call/nargs, but it's not so nice.
              ((vals) (emit-code src (make-glil-mv-call len MVRA))
                      (maybe-emit-return))
              ((drop) (let ((MV (make-label)) (POST (make-label)))
@@ -402,13 +414,12 @@
                 ;; values-mismatch warning pass.
                 (comp-push (make-call src (make-primitive-ref #f 'values)
                                       '())))
-               ((1)
-                (comp-push (car args)))
                (else
                 ;; Taking advantage of unspecified order of evaluation of
                 ;; arguments.
                 (for-each comp-drop (cdr args))
-                (comp-push (car args)))))
+                (comp-push (car args))
+                (maybe-emit-return))))
             ((vals)
              (for-each comp-push args)
              (emit-code #f (make-glil-const (length args)))
@@ -528,6 +539,9 @@
               ((null? ,x)
                (comp-push x)
                (emit-branch src 'br-if-not-null L1))
+              ((nil? ,x)
+               (comp-push x)
+               (emit-branch src 'br-if-not-nil L1))
               ((not ,x)
                (record-case x
                  ((<primcall> name args)
@@ -539,6 +553,9 @@
                     ((null? ,x)
                      (comp-push x)
                      (emit-branch src 'br-if-null L1))
+                    ((nil? ,x)
+                     (comp-push x)
+                     (emit-branch src 'br-if-nil L1))
                     (else
                      (comp-push x)
                      (emit-branch src 'br-if L1))))
@@ -922,7 +939,31 @@
       ;; then proceed with returning or dropping or what-have-you, interacting
       ;; with RA and MVRA. What have you, I say.
       ((<dynwind> src winder pre body post unwinder)
+       (define (thunk? x)
+         (and (lambda? x)
+              (null? (lambda-case-gensyms (lambda-body x)))))
+       (define (make-wrong-type-arg x)
+         (make-primcall src 'scm-error
+                        (list
+                         (make-const #f 'wrong-type-arg)
+                         (make-const #f "dynamic-wind")
+                         (make-const #f "Wrong type (expecting thunk): ~S")
+                         (make-primcall #f 'list (list x))
+                         (make-primcall #f 'list (list x)))))
+       (define (emit-thunk-check x)
+         (comp-drop (make-conditional
+                     src
+                     (make-primcall src 'thunk? (list x))
+                     (make-void #f)
+                     (make-wrong-type-arg x))))
+
+       ;; We know at this point that `winder' and `unwinder' are
+       ;; constant expressions and can be duplicated.
+       (if (not (thunk? winder))
+           (emit-thunk-check winder))
        (comp-push winder)
+       (if (not (thunk? unwinder))
+           (emit-thunk-check unwinder))
        (comp-push unwinder)
        (comp-drop pre)
        (emit-code #f (make-glil-call 'wind 2))