;;; TREE-IL -> GLIL compiler
-;; Copyright (C) 2001,2008,2009,2010,2011,2012 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
((list? . 1) . list?)
((symbol? . 1) . symbol?)
((vector? . 1) . vector?)
+ ((nil? . 1) . nil?)
(list . list)
(vector . vector)
((class-of . 1) . class-of)
(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)))
((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)
((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))))
;; 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))