X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/2f9ae9b1040e1b9339bb0bc8b0013a5346622c44..46abd569d545d07a05e0bdbbe16750c31dd7140e:/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 94ace7e53..e0df038d8 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -2,20 +2,19 @@ ;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc. -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: @@ -23,6 +22,7 @@ #:use-module (system base syntax) #:use-module (ice-9 receive) #:use-module (language glil) + #:use-module (system vm instruction) #:use-module (language tree-il) #:use-module (language tree-il optimize) #:use-module (language tree-il analyze) @@ -81,7 +81,53 @@ (list . list) (vector . vector) ((@slot-ref . 2) . slot-ref) - ((@slot-set! . 3) . slot-set))) + ((@slot-set! . 3) . slot-set) + ((vector-ref . 2) . vector-ref) + ((vector-set! . 3) . vector-set) + + ((bytevector-u8-ref . 2) . bv-u8-ref) + ((bytevector-u8-set! . 3) . bv-u8-set) + ((bytevector-s8-ref . 2) . bv-s8-ref) + ((bytevector-s8-set! . 3) . bv-s8-set) + + ((bytevector-u16-ref . 3) . bv-u16-ref) + ((bytevector-u16-set! . 4) . bv-u16-set) + ((bytevector-u16-native-ref . 2) . bv-u16-native-ref) + ((bytevector-u16-native-set! . 3) . bv-u16-native-set) + ((bytevector-s16-ref . 3) . bv-s16-ref) + ((bytevector-s16-set! . 4) . bv-s16-set) + ((bytevector-s16-native-ref . 2) . bv-s16-native-ref) + ((bytevector-s16-native-set! . 3) . bv-s16-native-set) + + ((bytevector-u32-ref . 3) . bv-u32-ref) + ((bytevector-u32-set! . 4) . bv-u32-set) + ((bytevector-u32-native-ref . 2) . bv-u32-native-ref) + ((bytevector-u32-native-set! . 3) . bv-u32-native-set) + ((bytevector-s32-ref . 3) . bv-s32-ref) + ((bytevector-s32-set! . 4) . bv-s32-set) + ((bytevector-s32-native-ref . 2) . bv-s32-native-ref) + ((bytevector-s32-native-set! . 3) . bv-s32-native-set) + + ((bytevector-u64-ref . 3) . bv-u64-ref) + ((bytevector-u64-set! . 4) . bv-u64-set) + ((bytevector-u64-native-ref . 2) . bv-u64-native-ref) + ((bytevector-u64-native-set! . 3) . bv-u64-native-set) + ((bytevector-s64-ref . 3) . bv-s64-ref) + ((bytevector-s64-set! . 4) . bv-s64-set) + ((bytevector-s64-native-ref . 2) . bv-s64-native-ref) + ((bytevector-s64-native-set! . 3) . bv-s64-native-set) + + ((bytevector-ieee-single-ref . 3) . bv-f32-ref) + ((bytevector-ieee-single-set! . 4) . bv-f32-set) + ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref) + ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set) + ((bytevector-ieee-double-ref . 3) . bv-f64-ref) + ((bytevector-ieee-double-set! . 4) . bv-f64-set) + ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref) + ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set))) + + + (define (make-label) (gensym ":L")) @@ -150,22 +196,24 @@ (define (emit-branch src inst label) (emit-code src (make-glil-branch inst label))) - (let comp ((x x) (context 'tail)) - (define (comp-tail tree) (comp tree context)) - (define (comp-push tree) (comp tree 'push)) - (define (comp-drop tree) (comp tree 'drop)) + ;; LMVRA == "let-values MV return address" + (let comp ((x x) (context 'tail) (LMVRA #f)) + (define (comp-tail tree) (comp tree context LMVRA)) + (define (comp-push tree) (comp tree 'push #f)) + (define (comp-drop tree) (comp tree 'drop #f)) + (define (comp-vals tree LMVRA) (comp tree 'vals LMVRA)) (record-case x (() (case context - ((push) (emit-code #f (make-glil-void))) + ((push vals) (emit-code #f (make-glil-void))) ((tail) (emit-code #f (make-glil-void)) (emit-code #f (make-glil-call 'return 1))))) (( src exp) (case context - ((push) (emit-code src (make-glil-const exp))) + ((push vals) (emit-code src (make-glil-const exp))) ((tail) (emit-code src (make-glil-const exp)) (emit-code #f (make-glil-call 'return 1))))) @@ -189,7 +237,7 @@ (args (cdr args))) (cond ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) - (not (eq? context 'push))) + (not (eq? context 'push)) (not (eq? context 'vals))) ;; tail: (lambda () (apply values '(1 2))) ;; drop: (lambda () (apply values '(1 2)) 3) ;; push: (lambda () (list (apply values '(10 12)) 1)) @@ -209,6 +257,11 @@ (comp-push proc) (for-each comp-push args) (emit-code src (make-glil-call 'apply (1+ (length args))))) + ((vals) + (comp-vals + (make-application src (make-primitive-ref #f 'apply) + (cons proc args)) + LMVRA)) ((drop) ;; Well, shit. The proc might return any number of ;; values (including 0), since it's in a drop context, @@ -223,11 +276,17 @@ ;; tail: (lambda () (values '(1 2))) ;; drop: (lambda () (values '(1 2)) 3) ;; push: (lambda () (list (values '(10 12)) 1)) + ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...) (case context ((drop) (for-each comp-drop args)) + ((vals) + (for-each comp-push args) + (emit-code #f (make-glil-const (length args))) + (emit-branch src 'br LMVRA)) ((tail) (for-each comp-push args) (emit-code src (make-glil-call 'return/values (length args)))))) + ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) '@call-with-values) (= (length args) 2)) @@ -238,22 +297,30 @@ ;; 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))))))) + (case context + ((vals) + ;; Fall back. + (comp-vals + (make-application src (make-primitive-ref #f 'call-with-values) + args) + LMVRA)) + (else + (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) @@ -262,6 +329,12 @@ ((tail) (comp-push (car args)) (emit-code src (make-glil-call 'goto/cc 1))) + ((vals) + (comp-vals + (make-application + src (make-primitive-ref #f 'call-with-current-continuation) + args) + LMVRA)) ((push) (comp-push (car args)) (emit-code src (make-glil-call 'call/cc 1))) @@ -279,9 +352,20 @@ => (lambda (op) (for-each comp-push args) (emit-code src (make-glil-call op (length args))) - (case context - ((tail) (emit-code #f (make-glil-call 'return 1))) - ((drop) (emit-code #f (make-glil-call 'drop 1)))))) + (case (instruction-pushes op) + ((0) + (case context + ((tail) (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-call 'return 1))) + ((push vals) (emit-code #f (make-glil-void))))) + ((1) + (case context + ((tail) (emit-code #f (make-glil-call 'return 1))) + ((drop) (emit-code #f (make-glil-call 'drop 1))))) + (else + (error "bad primitive op: too many pushes" + op (instruction-pushes op)))))) + (else (comp-push proc) (for-each comp-push args) @@ -289,6 +373,7 @@ (case context ((tail) (emit-code src (make-glil-call 'goto/args len))) ((push) (emit-code src (make-glil-call 'call len))) + ((vals) (emit-code src (make-glil-call 'mv-call len LMVRA))) ((drop) (let ((MV (make-label)) (POST (make-label))) (emit-code src (make-glil-mv-call len MV)) @@ -322,7 +407,7 @@ ((eq? (module-variable (fluid-ref *comp-module*) name) (module-variable the-root-module name)) (case context - ((push) + ((push vals) (emit-code src (make-glil-toplevel 'ref name))) ((tail) (emit-code src (make-glil-toplevel 'ref name)) @@ -330,7 +415,7 @@ (else (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*)) (case context - ((push) + ((push vals) (emit-code src (make-glil-module 'ref '(guile) name #f))) ((tail) (emit-code src (make-glil-module 'ref '(guile) name #f)) @@ -338,7 +423,7 @@ (( src name gensym) (case context - ((push tail) + ((push vals tail) (let ((loc (hashq-ref allocation gensym))) (case (car loc) ((stack) @@ -361,7 +446,7 @@ 'set (- level (cadr loc)) (cddr loc)))) (else (error "badness" x loc)))) (case context - ((push) + ((push vals) (emit-code #f (make-glil-void))) ((tail) (emit-code #f (make-glil-void)) @@ -377,7 +462,7 @@ (comp-push exp) (emit-code src (make-glil-module 'set mod name public?)) (case context - ((push) + ((push vals) (emit-code #f (make-glil-void))) ((tail) (emit-code #f (make-glil-void)) @@ -393,7 +478,7 @@ (comp-push exp) (emit-code src (make-glil-toplevel 'set name)) (case context - ((push) + ((push vals) (emit-code #f (make-glil-void))) ((tail) (emit-code #f (make-glil-void)) @@ -403,7 +488,7 @@ (comp-push exp) (emit-code src (make-glil-toplevel 'define name)) (case context - ((push) + ((push vals) (emit-code #f (make-glil-void))) ((tail) (emit-code #f (make-glil-void)) @@ -411,13 +496,13 @@ (() (case context - ((push) + ((push vals) (emit-code #f (flatten-lambda x level allocation))) ((tail) (emit-code #f (flatten-lambda x level allocation)) (emit-code #f (make-glil-call 'return 1))))) - (( src names vars vals exp) + (( src names vars vals body) (for-each comp-push vals) (emit-bindings src names vars allocation emit-code) (for-each (lambda (v) @@ -429,10 +514,10 @@ (emit-code src (make-glil-external 'set 0 (cddr loc)))) (else (error "badness" x loc))))) (reverse vars)) - (comp-tail exp) + (comp-tail body) (emit-code #f (make-glil-unbind))) - (( src names vars vals exp) + (( src names vars vals body) (for-each comp-push vals) (emit-bindings src names vars allocation emit-code) (for-each (lambda (v) @@ -444,5 +529,35 @@ (emit-code src (make-glil-external 'set 0 (cddr loc)))) (else (error "badness" x loc))))) (reverse vars)) - (comp-tail exp) - (emit-code #f (make-glil-unbind)))))) + (comp-tail body) + (emit-code #f (make-glil-unbind))) + + (( src names vars exp body) + (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f)) + (cond + ((pair? inames) + (lp (cons (car inames) names) (cons (car ivars) vars) + (cdr inames) (cdr ivars) #f)) + ((not (null? inames)) + (lp (cons inames names) (cons ivars vars) '() '() #t)) + (else + (let ((names (reverse! names)) + (vars (reverse! vars)) + (MV (make-label))) + (comp-vals exp MV) + (emit-code #f (make-glil-const 1)) + (emit-label MV) + (emit-code src (make-glil-mv-bind + (vars->bind-list names vars allocation) + rest?)) + (for-each (lambda (v) + (let ((loc (hashq-ref allocation v))) + (case (car loc) + ((stack) + (emit-code src (make-glil-local 'set (cdr loc)))) + ((heap) + (emit-code src (make-glil-external 'set 0 (cddr loc)))) + (else (error "badness" x loc))))) + (reverse vars)) + (comp-tail body) + (emit-code #f (make-glil-unbind))))))))))