X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/ab4bc85398a14b62b58694bab83c63be286b2fd5..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 a22063b0e..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 @@ -27,6 +27,7 @@ #:use-module (system vm instruction) #:use-module (language tree-il) #:use-module (language tree-il optimize) + #:use-module (language tree-il canonicalize) #:use-module (language tree-il analyze) #:use-module ((srfi srfi-1) #:select (filter-map)) #:export (compile-glil)) @@ -64,6 +65,7 @@ (let* ((x (make-lambda (tree-il-src x) '() (make-lambda-case #f '() #f #f #f '() '() x #f))) (x (optimize! x e opts)) + (x (canonicalize! x)) (allocation (analyze-lexicals x))) (with-fluids ((*comp-module* e)) @@ -108,11 +110,15 @@ ((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) @@ -235,6 +241,24 @@ (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 (() (case context @@ -320,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))) @@ -379,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))) @@ -505,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 (( name args) @@ -516,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)))) @@ -743,6 +783,7 @@ (,loc (error "bad let var allocation" x loc)))) (reverse gensyms)) (comp-tail body) + (clear-stack-slots context gensyms) (emit-code #f (make-glil-unbind))) (( src in-order? names gensyms vals body) @@ -775,6 +816,7 @@ (,loc (error "bad letrec var allocation" x loc)))) (reverse gensyms)))) (comp-tail body) + (clear-stack-slots context gensyms) (emit-code #f (make-glil-unbind))) (( src names gensyms vals body) @@ -863,6 +905,7 @@ (comp-tail body) (if new-RA (emit-label new-RA)) + (clear-stack-slots context gensyms) (emit-code #f (make-glil-unbind)))) (( src exp body) @@ -888,16 +931,41 @@ (,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. - (( src body winder unwinder) + (( 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 @@ -906,14 +974,14 @@ (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)))) @@ -922,7 +990,7 @@ (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))) @@ -933,7 +1001,7 @@ (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))) @@ -941,7 +1009,7 @@ ;; 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)))))