;; 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 (system base message)
#: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))
+(define %warning-passes
+ `((unused-variable . ,report-unused-variables)))
+
(define (compile-glil x e opts)
+ (define warnings
+ (or (and=> (memq #:warnings opts) cadr)
+ '()))
+
(let* ((x (make-lambda (tree-il-src x) '() '() '() x))
(x (optimize! x e opts))
(allocation (analyze-lexicals x)))
+
+ ;; Go throught the warning passes.
+ (for-each (lambda (kind)
+ (let ((warn (assoc-ref %warning-passes kind)))
+ (and (procedure? warn)
+ (warn x))))
+ warnings)
+
(with-fluid* *comp-module* (or (and e (car e)) (current-module))
(lambda ()
- (values (flatten-lambda x -1 allocation)
+ (values (flatten-lambda x #f allocation)
(and e (cons (car e) (cddr e)))
e)))))
((>= . 2) . ge?)
((+ . 2) . add)
((- . 2) . sub)
+ ((1+ . 1) . add1)
+ ((1- . 1) . sub1)
((* . 2) . mul)
((/ . 2) . div)
((quotient . 2) . quo)
(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 self-label 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)
+ ;; emit label for self tail calls
+ (if self-label
+ (emit-code #f (make-glil-label self-label)))
;; 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 self-label emit-code)))))))
-(define (flatten x level allocation emit-code)
+(define (flatten x allocation self self-label emit-code)
(define (emit-label label)
(emit-code #f (make-glil-label label)))
(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))))))
+
+ ;; da capo al fine
+ ((and (lexical-ref? proc)
+ self-label (eq? (lexical-ref-gensym proc) self-label)
+ ;; self-call in tail position is a goto
+ (eq? context 'tail)
+ ;; make sure the arity is right
+ (list? (lambda-vars self))
+ (= (length args) (length (lambda-vars self))))
+ ;; evaluate new values
+ (for-each comp-push args)
+ ;; rename & goto
+ (for-each (lambda (sym)
+ (pmatch (hashq-ref (hashq-ref allocation sym) self)
+ ((#t ,boxed? . ,index)
+ (emit-code #f (make-glil-lexical #t #f 'set index)))
+ (,x (error "what" x))))
+ (reverse (lambda-vars self)))
+ (emit-branch src 'br self-label))
+
(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-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)
- (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)))))))
-
+ ((push vals tail)
+ (pmatch (hashq-ref (hashq-ref allocation gensym) self)
+ ((,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) self)
+ ((,local? ,boxed? . ,index)
+ (emit-code src (make-glil-lexical local? boxed? 'set index)))
+ (,loc
+ (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))
(emit-code #f (make-glil-call 'return 1)))))
((<lambda>)
- (case context
- ((push)
- (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 ((free-locs (cddr (hashq-ref allocation x))))
+ (case context
+ ((push vals tail)
+ (emit-code #f (flatten-lambda x #f 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 self 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) self)
+ ((#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 exp)
+ (comp-tail body)
(emit-code #f (make-glil-unbind)))
- ((<letrec> src names vars vals exp)
+ ((<letrec> src names vars vals body)
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#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 self 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) self)
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'set n)))
+ (,loc (error "badness" x loc))))
(reverse vars))
- (comp-tail exp)
- (emit-code #f (make-glil-unbind))))))
+ (comp-tail body)
+ (emit-code #f (make-glil-unbind)))
+
+ ((<fix> src names vars vals body)
+ ;; For fixpoint procedures, we can do some tricks to avoid
+ ;; heap-allocation. Since we know the vals are lambdas, we can
+ ;; set them to their local var slots first, then capture their
+ ;; bindings, mutating them in place.
+ (for-each (lambda (x v)
+ (emit-code #f (flatten-lambda x v allocation))
+ (if (not (null? (cddr (hashq-ref allocation x))))
+ ;; But we do have to make-closure them first, so
+ ;; we are mutating fresh closures on the heap.
+ (begin
+ (emit-code #f (make-glil-const #f))
+ (emit-code #f (make-glil-call 'make-closure 2))))
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ (,loc (error "badness" x loc))))
+ vals
+ vars)
+ (emit-bindings src names vars allocation self emit-code)
+ ;; Now go back and fix up the bindings.
+ (for-each
+ (lambda (x v)
+ (let ((free-locs (cddr (hashq-ref allocation x))))
+ (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)))
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code #f (make-glil-lexical #t #f 'fix n)))
+ (,loc (error "badness" x loc)))))))
+ vals
+ vars)
+ (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 self)
+ rest?))
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#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