;; 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:
#: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)
(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)))
+
+
+\f
(define (make-label) (gensym ":L"))
(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
((<void>)
(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)))))
((<const> 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)))))
(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))
(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,
;; 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))
;; 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)
((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)))
=> (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)
(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))
((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))
(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))
((<lexical-ref> src name gensym)
(case context
- ((push tail)
+ ((push vals tail)
(let ((loc (hashq-ref allocation gensym)))
(case (car loc)
((stack)
'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))
(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))
(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))
(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))
((<lambda>)
(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)))))
- ((<let> src names vars vals exp)
+ ((<let> src names vars vals body)
(for-each comp-push vals)
(emit-bindings src names vars allocation emit-code)
(for-each (lambda (v)
(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)))
- ((<letrec> src names vars vals exp)
+ ((<letrec> src names vars vals body)
(for-each comp-push vals)
(emit-bindings src names vars allocation emit-code)
(for-each (lambda (v)
(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)))
+
+ ((<let-values> 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))))))))))
HCoop / bpt / guile.git / blobdiff