;;; 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
((list? . 1) . list?)
((symbol? . 1) . symbol?)
((vector? . 1) . vector?)
+ ((nil? . 1) . nil?)
(list . list)
(vector . vector)
((class-of . 1) . class-of)
((@slot-ref . 2) . slot-ref)
((@slot-set! . 3) . slot-set)
+ ((string-length . 1) . string-length)
+ ((string-ref . 2) . string-ref)
+ ((vector-length . 1) . vector-length)
((vector-ref . 2) . vector-ref)
((vector-set! . 3) . vector-set)
((variable-ref . 1) . variable-ref)
(if (eq? context 'tail)
(emit-code #f (make-glil-call 'return 1)))))
+ ;; After lexical binding forms in non-tail context, call this
+ ;; function to clear stack slots, allowing their previous values to
+ ;; be collected.
+ (define (clear-stack-slots context syms)
+ (case context
+ ((push drop)
+ (for-each (lambda (v)
+ (and=>
+ ;; Can be #f if the var is labels-allocated.
+ (hashq-ref allocation v)
+ (lambda (h)
+ (pmatch (hashq-ref h self)
+ ((#t _ . ,n)
+ (emit-code #f (make-glil-void))
+ (emit-code #f (make-glil-lexical #t #f 'set n)))
+ (,loc (error "bad let var allocation" x loc))))))
+ syms))))
+
(record-case x
((<void>)
(case context
(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)))
;; 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)))
((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))))
(,loc (error "bad let var allocation" x loc))))
(reverse gensyms))
(comp-tail body)
+ (clear-stack-slots context gensyms)
(emit-code #f (make-glil-unbind)))
((<letrec> src in-order? names gensyms vals body)
(,loc (error "bad letrec var allocation" x loc))))
(reverse gensyms))))
(comp-tail body)
+ (clear-stack-slots context gensyms)
(emit-code #f (make-glil-unbind)))
((<fix> src names gensyms vals body)
(comp-tail body)
(if new-RA
(emit-label new-RA))
+ (clear-stack-slots context gensyms)
(emit-code #f (make-glil-unbind))))
((<let-values> src exp body)
(,loc (error "bad let-values var allocation" x loc))))
(reverse gensyms))
(comp-tail body)
+ (clear-stack-slots context gensyms)
(emit-code #f (make-glil-unbind))))))
;; much trickier than i thought this would be, at first, due to the need
;; to have body's return value(s) on the stack while the unwinder runs,
;; then proceed with returning or dropping or what-have-you, interacting
;; with RA and MVRA. What have you, I say.
- ((<dynwind> src body winder unwinder)
+ ((<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 (make-call src winder '()))
+ (comp-drop pre)
(emit-code #f (make-glil-call 'wind 2))
(case context
(comp-vals body MV)
;; one value: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-call src unwinder '()))
+ (comp-drop post)
;; ...and return the val
(emit-code #f (make-glil-call 'return 1))
(emit-label MV)
;; multiple values: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-call src unwinder '()))
+ (comp-drop post)
;; and return the values.
(emit-code #f (make-glil-call 'return/nvalues 1))))
(comp-push body)
;; and unwind, leaving the val on the stack
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-call src unwinder '())))
+ (comp-drop post))
((vals)
(let ((MV (make-label)))
(emit-label MV)
;; multiple values: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-call src unwinder '()))
+ (comp-drop post)
;; and goto the MVRA.
(emit-branch #f 'br MVRA)))
;; compile body, discarding values. then unwind...
(comp-drop body)
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-call src unwinder '()))
+ (comp-drop post)
;; and fall through, or goto RA if there is one.
(if RA
(emit-branch #f 'br RA)))))
HCoop / bpt / guile.git / blobdiff