;; 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:
(define-module (language tree-il compile-glil)
#:use-module (system base syntax)
+ #:use-module (system base pmatch)
#: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)
;; basic degenerate-case reduction
;; allocation:
-;; sym -> (local . index) | (heap level . index)
-;; lambda -> (nlocs . nexts)
+;; sym -> {lambda -> address}
+;; lambda -> (nlocs . closure-vars)
+;;
+;; address := (local? boxed? . index)
+;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
+;; free variable addresses are relative to parent proc.
(define *comp-module* (make-fluid))
(allocation (analyze-lexicals x)))
(with-fluid* *comp-module* (or (and e (car e)) (current-module))
(lambda ()
- (values (flatten-lambda x -1 allocation)
+ (values (flatten-lambda x allocation)
(and e (cons (car e) (cddr e)))
e)))))
(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 (vars->bind-list ids vars allocation)
+(define (vars->bind-list ids vars allocation proc)
(map (lambda (id v)
- (let ((loc (hashq-ref allocation v)))
- (case (car loc)
- ((stack) (list id 'local (cdr loc)))
- ((heap) (list id 'external (cddr loc)))
- (else (error "badness" id v loc)))))
+ (pmatch (hashq-ref (hashq-ref allocation v) proc)
+ ((#t ,boxed? . ,n)
+ (list id boxed? n))
+ (,x (error "badness" x))))
ids
vars))
-(define (emit-bindings src ids vars allocation emit-code)
+(define (emit-bindings src ids vars allocation proc emit-code)
(if (pair? vars)
(emit-code src (make-glil-bind
- (vars->bind-list ids vars allocation)))))
+ (vars->bind-list ids vars allocation proc)))))
(define (with-output-to-code proc)
(let ((out '()))
(proc emit-code)
(reverse out)))
-(define (flatten-lambda x level allocation)
+(define (flatten-lambda x allocation)
(receive (ids vars nargs nrest)
(let lp ((ids (lambda-names x)) (vars (lambda-vars x))
(oids '()) (ovars '()) (n 0))
(else (values (reverse (cons ids oids))
(reverse (cons vars ovars))
(1+ n) 1))))
- (let ((nlocs (car (hashq-ref allocation x)))
- (nexts (cdr (hashq-ref allocation x))))
+ (let ((nlocs (car (hashq-ref allocation x))))
(make-glil-program
- nargs nrest nlocs nexts (lambda-meta x)
+ nargs nrest nlocs (lambda-meta x)
(with-output-to-code
(lambda (emit-code)
;; write bindings and source debugging info
- (emit-bindings #f ids vars allocation emit-code)
+ (emit-bindings #f ids vars allocation x emit-code)
(if (lambda-src x)
(emit-code #f (make-glil-source (lambda-src x))))
-
- ;; copy args to the heap if necessary
- (let lp ((in vars) (n 0))
- (if (not (null? in))
- (let ((loc (hashq-ref allocation (car in))))
- (case (car loc)
- ((heap)
- (emit-code #f (make-glil-local 'ref n))
- (emit-code #f (make-glil-external 'set 0 (cddr loc)))))
- (lp (cdr in) (1+ n)))))
-
+ ;; box args if necessary
+ (for-each
+ (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) x)
+ ((#t #t . ,n)
+ (emit-code #f (make-glil-lexical #t #f 'ref n))
+ (emit-code #f (make-glil-lexical #t #t 'box n)))))
+ vars)
;; and here, here, dear reader: we compile.
- (flatten (lambda-body x) (1+ level) allocation emit-code)))))))
+ (flatten (lambda-body x) allocation x emit-code)))))))
-(define (flatten x level allocation emit-code)
+(define (flatten x allocation proc emit-code)
(define (emit-label label)
(emit-code #f (make-glil-label label)))
(define (emit-branch src inst label)
=> (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)
((<lexical-ref> src name gensym)
(case context
((push vals tail)
- (let ((loc (hashq-ref allocation gensym)))
- (case (car loc)
- ((stack)
- (emit-code src (make-glil-local 'ref (cdr loc))))
- ((heap)
- (emit-code src (make-glil-external
- 'ref (- level (cadr loc)) (cddr loc))))
- (else (error "badness" x loc)))
- (if (eq? context 'tail)
- (emit-code #f (make-glil-call 'return 1)))))))
-
+ (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
+ ((,local? ,boxed? . ,index)
+ (emit-code src (make-glil-lexical local? boxed? 'ref index)))
+ (,loc
+ (error "badness" x loc)))))
+ (case context
+ ((tail) (emit-code #f (make-glil-call 'return 1)))))
+
((<lexical-set> src name gensym exp)
(comp-push exp)
- (let ((loc (hashq-ref allocation gensym)))
- (case (car loc)
- ((stack)
- (emit-code src (make-glil-local 'set (cdr loc))))
- ((heap)
- (emit-code src (make-glil-external
- 'set (- level (cadr loc)) (cddr loc))))
- (else (error "badness" x loc))))
+ (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
+ ((,local? ,boxed? . ,index)
+ (emit-code src (make-glil-lexical local? boxed? 'set index)))
+ (,loc
+ (error "badness" x loc)))
(case context
((push vals)
(emit-code #f (make-glil-void)))
(emit-code #f (make-glil-call 'return 1)))))
((<lambda>)
- (case context
- ((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 ((free-locs (cdr (hashq-ref allocation x))))
+ (case context
+ ((push vals tail)
+ (emit-code #f (flatten-lambda x allocation))
+ (if (not (null? free-locs))
+ (begin
+ (for-each
+ (lambda (loc)
+ (pmatch loc
+ ((,local? ,boxed? . ,n)
+ (emit-code #f (make-glil-lexical local? #f 'ref n)))
+ (else (error "what" x loc))))
+ free-locs)
+ (emit-code #f (make-glil-call 'vector (length free-locs)))
+ (emit-code #f (make-glil-call 'make-closure 2))))
+ (if (eq? context 'tail)
+ (emit-code #f (make-glil-call 'return 1)))))))
+
((<let> src names vars vals body)
(for-each comp-push vals)
- (emit-bindings src names vars allocation emit-code)
+ (emit-bindings src names vars allocation proc emit-code)
(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)))))
+ (pmatch (hashq-ref (hashq-ref allocation v) proc)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'box n)))
+ (,loc (error "badness" x loc))))
(reverse vars))
(comp-tail body)
(emit-code #f (make-glil-unbind)))
((<letrec> src names vars vals body)
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) proc)
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'empty-box n)))
+ (,loc (error "badness" x loc))))
+ vars)
(for-each comp-push vals)
- (emit-bindings src names vars allocation emit-code)
+ (emit-bindings src names vars allocation proc emit-code)
(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)))))
+ (pmatch (hashq-ref (hashq-ref allocation v) proc)
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'set n)))
+ (,loc (error "badness" x loc))))
(reverse vars))
(comp-tail body)
(emit-code #f (make-glil-unbind)))
(emit-code #f (make-glil-const 1))
(emit-label MV)
(emit-code src (make-glil-mv-bind
- (vars->bind-list names vars allocation)
+ (vars->bind-list names vars allocation proc)
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)))))
+ (pmatch (hashq-ref (hashq-ref allocation v) proc)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'box n)))
+ (,loc (error "badness" x loc))))
(reverse vars))
(comp-tail body)
(emit-code #f (make-glil-unbind))))))))))
HCoop / bpt / guile.git / blobdiff