-;;; TREE-IL -> GLIL compiler
-
-;; Copyright (C) 2001,2008,2009 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
-;;;; 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 analyze)
- #:use-module (system base syntax)
- #:use-module (language tree-il)
- #:export (analyze-lexicals))
-
-;; allocation: the process of assigning a type and index to each var
-;; a var is external if it is heaps; assigning index is easy
-;; args are assigned in order
-;; locals are indexed as their linear position in the binding path
-;; (let (0 1)
-;; (let (2 3) ...)
-;; (let (2) ...))
-;; (let (2 3 4) ...))
-;; etc.
-;;
-;; This algorithm has the problem that variables are only allocated
-;; indices at the end of the binding path. If variables bound early in
-;; the path are not used in later portions of the path, their indices
-;; will not be recycled. This problem is particularly egregious in the
-;; expansion of `or':
-;;
-;; (or x y z)
-;; -> (let ((a x)) (if a a (let ((b y)) (if b b z))))
-;;
-;; As you can see, the `a' binding is only used in the ephemeral `then'
-;; clause of the first `if', but its index would be reserved for the
-;; whole of the `or' expansion. So we have a hack for this specific
-;; case. A proper solution would be some sort of liveness analysis, and
-;; not our linear allocation algorithm.
-;;
-;; allocation:
-;; sym -> (local . index) | (heap level . index)
-;; lambda -> (nlocs . nexts)
-
-(define (analyze-lexicals x)
- ;; parents: lambda -> parent
- ;; useful when we see a closed-over var, so we can calculate its
- ;; coordinates (depth and index).
- ;; bindings: lambda -> (sym ...)
- ;; useful for two reasons: one, so we know how much space to allocate
- ;; when we go into a lambda; and two, so that we know when to stop,
- ;; when looking for closed-over vars.
- ;; heaps: sym -> lambda
- ;; allows us to heapify vars in an O(1) fashion
- ;; refcounts: sym -> count
- ;; allows us to detect the or-expansion an O(1) time
-
- (define (find-heap sym parent)
- ;; fixme: check displaced lexicals here?
- (if (memq sym (hashq-ref bindings parent))
- parent
- (find-heap sym (hashq-ref parents parent))))
-
- (define (analyze! x parent level)
- (define (step y) (analyze! y parent level))
- (define (recur x parent) (analyze! x parent (1+ level)))
- (record-case x
- ((<application> proc args)
- (step proc) (for-each step args))
-
- ((<conditional> test then else)
- (step test) (step then) (step else))
-
- ((<lexical-ref> name gensym)
- (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
- (if (and (not (memq gensym (hashq-ref bindings parent)))
- (not (hashq-ref heaps gensym)))
- (hashq-set! heaps gensym (find-heap gensym parent))))
-
- ((<lexical-set> name gensym exp)
- (step exp)
- (if (not (hashq-ref heaps gensym))
- (hashq-set! heaps gensym (find-heap gensym parent))))
-
- ((<module-set> mod name public? exp)
- (step exp))
-
- ((<toplevel-set> name exp)
- (step exp))
-
- ((<toplevel-define> name exp)
- (step exp))
-
- ((<sequence> exps)
- (for-each step exps))
-
- ((<lambda> vars meta body)
- (hashq-set! parents x parent)
- (hashq-set! bindings x
- (let rev* ((vars vars) (out '()))
- (cond ((null? vars) out)
- ((pair? vars) (rev* (cdr vars)
- (cons (car vars) out)))
- (else (cons vars out)))))
- (recur body x)
- (hashq-set! bindings x (reverse! (hashq-ref bindings x))))
-
- ((<let> vars vals body)
- (for-each step vals)
- (hashq-set! bindings parent
- (append (reverse vars) (hashq-ref bindings parent)))
- (step body))
-
- ((<letrec> vars vals body)
- (hashq-set! bindings parent
- (append (reverse vars) (hashq-ref bindings parent)))
- (for-each step vals)
- (step body))
-
- ((<let-values> vars exp body)
- (hashq-set! bindings parent
- (let lp ((out (hashq-ref bindings parent)) (in vars))
- (if (pair? in)
- (lp (cons (car in) out) (cdr in))
- (if (null? in) out (cons in out)))))
- (step exp)
- (step body))
-
- (else #f)))
-
- (define (allocate-heap! binder)
- (hashq-set! heap-indexes binder
- (1+ (hashq-ref heap-indexes binder -1))))
-
- (define (allocate! x level n)
- (define (recur y) (allocate! y level n))
- (record-case x
- ((<application> proc args)
- (apply max (recur proc) (map recur args)))
-
- ((<conditional> test then else)
- (max (recur test) (recur then) (recur else)))
-
- ((<lexical-set> name gensym exp)
- (recur exp))
-
- ((<module-set> mod name public? exp)
- (recur exp))
-
- ((<toplevel-set> name exp)
- (recur exp))
-
- ((<toplevel-define> name exp)
- (recur exp))
-
- ((<sequence> exps)
- (apply max (map recur exps)))
-
- ((<lambda> vars meta body)
- (let lp ((vars vars) (n 0))
- (if (null? vars)
- (hashq-set! allocation x
- (let ((nlocs (- (allocate! body (1+ level) n) n)))
- (cons nlocs (1+ (hashq-ref heap-indexes x -1)))))
- (let ((v (if (pair? vars) (car vars) vars)))
- (let ((binder (hashq-ref heaps v)))
- (hashq-set!
- allocation v
- (if binder
- (cons* 'heap (1+ level) (allocate-heap! binder))
- (cons 'stack n))))
- (lp (if (pair? vars) (cdr vars) '()) (1+ n)))))
- n)
-
- ((<let> vars vals body)
- (let ((nmax (apply max (map recur vals))))
- (cond
- ;; the `or' hack
- ((and (conditional? body)
- (= (length vars) 1)
- (let ((v (car vars)))
- (and (not (hashq-ref heaps v))
- (= (hashq-ref refcounts v 0) 2)
- (lexical-ref? (conditional-test body))
- (eq? (lexical-ref-gensym (conditional-test body)) v)
- (lexical-ref? (conditional-then body))
- (eq? (lexical-ref-gensym (conditional-then body)) v))))
- (hashq-set! allocation (car vars) (cons 'stack n))
- ;; the 1+ for this var
- (max nmax (1+ n) (allocate! (conditional-else body) level n)))
- (else
- (let lp ((vars vars) (n n))
- (if (null? vars)
- (max nmax (allocate! body level n))
- (let ((v (car vars)))
- (let ((binder (hashq-ref heaps v)))
- (hashq-set!
- allocation v
- (if binder
- (cons* 'heap level (allocate-heap! binder))
- (cons 'stack n)))
- (lp (cdr vars) (if binder n (1+ n)))))))))))
-
- ((<letrec> vars vals body)
- (let lp ((vars vars) (n n))
- (if (null? vars)
- (let ((nmax (apply max
- (map (lambda (x)
- (allocate! x level n))
- vals))))
- (max nmax (allocate! body level n)))
- (let ((v (car vars)))
- (let ((binder (hashq-ref heaps v)))
- (hashq-set!
- allocation v
- (if binder
- (cons* 'heap level (allocate-heap! binder))
- (cons 'stack n)))
- (lp (cdr vars) (if binder n (1+ n))))))))
-
- ((<let-values> vars exp body)
- (let ((nmax (recur exp)))
- (let lp ((vars vars) (n n))
- (if (null? vars)
- (max nmax (allocate! body level n))
- (let ((v (if (pair? vars) (car vars) vars)))
- (let ((binder (hashq-ref heaps v)))
- (hashq-set!
- allocation v
- (if binder
- (cons* 'heap level (allocate-heap! binder))
- (cons 'stack n)))
- (lp (if (pair? vars) (cdr vars) '())
- (if binder n (1+ n)))))))))
-
- (else n)))
-
- (define parents (make-hash-table))
- (define bindings (make-hash-table))
- (define heaps (make-hash-table))
- (define refcounts (make-hash-table))
- (define allocation (make-hash-table))
- (define heap-indexes (make-hash-table))
-
- (analyze! x #f -1)
- (allocate! x -1 0)
-
- allocation)
+;;; TREE-IL -> GLIL compiler
+
+;; Copyright (C) 2001,2008,2009 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
+;;;; 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 analyze)
+ #:use-module (srfi srfi-1)
+ #:use-module (system base syntax)
+ #:use-module (language tree-il)
+ #:export (analyze-lexicals))
+
+;; Allocation is the process of assigning storage locations for lexical
+;; variables. A lexical variable has a distinct "address", or storage
+;; location, for each procedure in which it is referenced.
+;;
+;; A variable is "local", i.e., allocated on the stack, if it is
+;; referenced from within the procedure that defined it. Otherwise it is
+;; a "closure" variable. For example:
+;;
+;; (lambda (a) a) ; a will be local
+;; `a' is local to the procedure.
+;;
+;; (lambda (a) (lambda () a))
+;; `a' is local to the outer procedure, but a closure variable with
+;; respect to the inner procedure.
+;;
+;; If a variable is ever assigned, it needs to be heap-allocated
+;; ("boxed"). This is so that closures and continuations capture the
+;; variable's identity, not just one of the values it may have over the
+;; course of program execution. If the variable is never assigned, there
+;; is no distinction between value and identity, so closing over its
+;; identity (whether through closures or continuations) can make a copy
+;; of its value instead.
+;;
+;; Local variables are stored on the stack within a procedure's call
+;; frame. Their index into the stack is determined from their linear
+;; postion within a procedure's binding path:
+;; (let (0 1)
+;; (let (2 3) ...)
+;; (let (2) ...))
+;; (let (2 3 4) ...))
+;; etc.
+;;
+;; This algorithm has the problem that variables are only allocated
+;; indices at the end of the binding path. If variables bound early in
+;; the path are not used in later portions of the path, their indices
+;; will not be recycled. This problem is particularly egregious in the
+;; expansion of `or':
+;;
+;; (or x y z)
+;; -> (let ((a x)) (if a a (let ((b y)) (if b b z))))
+;;
+;; As you can see, the `a' binding is only used in the ephemeral `then'
+;; clause of the first `if', but its index would be reserved for the
+;; whole of the `or' expansion. So we have a hack for this specific
+;; case. A proper solution would be some sort of liveness analysis, and
+;; not our linear allocation algorithm.
+;;
+;; Closure variables are captured when a closure is created, and stored
+;; in a vector. Each closure variable has a unique index into that
+;; vector.
+;;
+;;
+;; The return value of `analyze-lexicals' is a hash table, the
+;; "allocation".
+;;
+;; The allocation maps gensyms -- recall that each lexically bound
+;; variable has a unique gensym -- to storage locations ("addresses").
+;; Since one gensym may have many storage locations, if it is referenced
+;; in many procedures, it is a two-level map.
+;;
+;; The allocation also stored information on how many local variables
+;; need to be allocated for each procedure, and information on what free
+;; variables to capture from its lexical parent procedure.
+;;
+;; That is:
+;;
+;; sym -> {lambda -> address}
+;; lambda -> (nlocs . free-locs)
+;;
+;; address := (local? boxed? . index)
+;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
+;; free variable addresses are relative to parent proc.
+
+(define (make-hashq k v)
+ (let ((res (make-hash-table)))
+ (hashq-set! res k v)
+ res))
+
+(define (analyze-lexicals x)
+ ;; bound-vars: lambda -> (sym ...)
+ ;; all identifiers bound within a lambda
+ ;; free-vars: lambda -> (sym ...)
+ ;; all identifiers referenced in a lambda, but not bound
+ ;; NB, this includes identifiers referenced by contained lambdas
+ ;; assigned: sym -> #t
+ ;; variables that are assigned
+ ;; refcounts: sym -> count
+ ;; allows us to detect the or-expansion in O(1) time
+
+ ;; returns variables referenced in expr
+ (define (analyze! x proc)
+ (define (step y) (analyze! y proc))
+ (define (recur x new-proc) (analyze! x new-proc))
+ (record-case x
+ ((<application> proc args)
+ (apply lset-union eq? (step proc) (map step args)))
+
+ ((<conditional> test then else)
+ (lset-union eq? (step test) (step then) (step else)))
+
+ ((<lexical-ref> name gensym)
+ (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
+ (list gensym))
+
+ ((<lexical-set> name gensym exp)
+ (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
+ (hashq-set! assigned gensym #t)
+ (lset-adjoin eq? (step exp) gensym))
+
+ ((<module-set> mod name public? exp)
+ (step exp))
+
+ ((<toplevel-set> name exp)
+ (step exp))
+
+ ((<toplevel-define> name exp)
+ (step exp))
+
+ ((<sequence> exps)
+ (apply lset-union eq? (map step exps)))
+
+ ((<lambda> vars meta body)
+ (let ((locally-bound (let rev* ((vars vars) (out '()))
+ (cond ((null? vars) out)
+ ((pair? vars) (rev* (cdr vars)
+ (cons (car vars) out)))
+ (else (cons vars out))))))
+ (hashq-set! bound-vars x locally-bound)
+ (let* ((referenced (recur body x))
+ (free (lset-difference eq? referenced locally-bound))
+ (all-bound (reverse! (hashq-ref bound-vars x))))
+ (hashq-set! bound-vars x all-bound)
+ (hashq-set! free-vars x free)
+ free)))
+
+ ((<let> vars vals body)
+ (hashq-set! bound-vars proc
+ (append (reverse vars) (hashq-ref bound-vars proc)))
+ (lset-difference eq?
+ (apply lset-union eq? (step body) (map step vals))
+ vars))
+
+ ((<letrec> vars vals body)
+ (hashq-set! bound-vars proc
+ (append (reverse vars) (hashq-ref bound-vars proc)))
+ (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars)
+ (lset-difference eq?
+ (apply lset-union eq? (step body) (map step vals))
+ vars))
+
+ ((<let-values> vars exp body)
+ (hashq-set! bound-vars proc
+ (let lp ((out (hashq-ref bound-vars proc)) (in vars))
+ (if (pair? in)
+ (lp (cons (car in) out) (cdr in))
+ (if (null? in) out (cons in out)))))
+ (lset-difference eq?
+ (lset-union eq? (step exp) (step body))
+ vars))
+
+ (else '())))
+
+ (define (allocate! x proc n)
+ (define (recur y) (allocate! y proc n))
+ (record-case x
+ ((<application> proc args)
+ (apply max (recur proc) (map recur args)))
+
+ ((<conditional> test then else)
+ (max (recur test) (recur then) (recur else)))
+
+ ((<lexical-set> name gensym exp)
+ (recur exp))
+
+ ((<module-set> mod name public? exp)
+ (recur exp))
+
+ ((<toplevel-set> name exp)
+ (recur exp))
+
+ ((<toplevel-define> name exp)
+ (recur exp))
+
+ ((<sequence> exps)
+ (apply max (map recur exps)))
+
+ ((<lambda> vars meta body)
+ ;; allocate closure vars in order
+ (let lp ((c (hashq-ref free-vars x)) (n 0))
+ (if (pair? c)
+ (begin
+ (hashq-set! (hashq-ref allocation (car c))
+ x
+ `(#f ,(hashq-ref assigned (car c)) . ,n))
+ (lp (cdr c) (1+ n)))))
+
+ (let ((nlocs
+ (let lp ((vars vars) (n 0))
+ (if (not (null? vars))
+ ;; allocate args
+ (let ((v (if (pair? vars) (car vars) vars)))
+ (hashq-set! allocation v
+ (make-hashq
+ x `(#t ,(hashq-ref assigned v) . ,n)))
+ (lp (if (pair? vars) (cdr vars) '()) (1+ n)))
+ ;; allocate body, return number of additional locals
+ (- (allocate! body x n) n))))
+ (free-addresses
+ (map (lambda (v)
+ (hashq-ref (hashq-ref allocation v) proc))
+ (hashq-ref free-vars x))))
+ ;; set procedure allocations
+ (hashq-set! allocation x (cons nlocs free-addresses)))
+ n)
+
+ ((<let> vars vals body)
+ (let ((nmax (apply max (map recur vals))))
+ (cond
+ ;; the `or' hack
+ ((and (conditional? body)
+ (= (length vars) 1)
+ (let ((v (car vars)))
+ (and (not (hashq-ref assigned v))
+ (= (hashq-ref refcounts v 0) 2)
+ (lexical-ref? (conditional-test body))
+ (eq? (lexical-ref-gensym (conditional-test body)) v)
+ (lexical-ref? (conditional-then body))
+ (eq? (lexical-ref-gensym (conditional-then body)) v))))
+ (hashq-set! allocation (car vars)
+ (make-hashq proc `(#t #f . ,n)))
+ ;; the 1+ for this var
+ (max nmax (1+ n) (allocate! (conditional-else body) proc n)))
+ (else
+ (let lp ((vars vars) (n n))
+ (if (null? vars)
+ (max nmax (allocate! body proc n))
+ (let ((v (car vars)))
+ (hashq-set!
+ allocation v
+ (make-hashq proc
+ `(#t ,(hashq-ref assigned v) . ,n)))
+ (lp (cdr vars) (1+ n)))))))))
+
+ ((<letrec> vars vals body)
+ (let lp ((vars vars) (n n))
+ (if (null? vars)
+ (let ((nmax (apply max
+ (map (lambda (x)
+ (allocate! x proc n))
+ vals))))
+ (max nmax (allocate! body proc n)))
+ (let ((v (car vars)))
+ (hashq-set!
+ allocation v
+ (make-hashq proc
+ `(#t ,(hashq-ref assigned v) . ,n)))
+ (lp (cdr vars) (1+ n))))))
+
+ ((<let-values> vars exp body)
+ (let ((nmax (recur exp)))
+ (let lp ((vars vars) (n n))
+ (if (null? vars)
+ (max nmax (allocate! body proc n))
+ (let ((v (if (pair? vars) (car vars) vars)))
+ (let ((v (car vars)))
+ (hashq-set!
+ allocation v
+ (make-hashq proc
+ `(#t ,(hashq-ref assigned v) . ,n)))
+ (lp (cdr vars) (1+ n))))))))
+
+ (else n)))
+
+ (define bound-vars (make-hash-table))
+ (define free-vars (make-hash-table))
+ (define assigned (make-hash-table))
+ (define refcounts (make-hash-table))
+
+ (define allocation (make-hash-table))
+
+ (analyze! x #f)
+ (allocate! x #f 0)
+
+ allocation)
(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)
;; 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)))))
(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 0 (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)
((<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-closure2 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))))))))))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (lexical x y))
(program 0 0 1 0 ()
- (const 1) (bind (x local 0)) (local set 0)
- (local ref 0) (call return 1)
+ (const 1) (bind (x #f 0)) (lexical #t #f set 0)
+ (lexical #t #f ref 0) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
(program 0 0 1 0 ()
- (const 1) (bind (x local 0)) (local set 0)
+ (const 1) (bind (x #f 0)) (lexical #t #f set 0)
(const #f) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
(program 0 0 1 0 ()
- (const 1) (bind (x local 0)) (local set 0)
- (local ref 0) (call null? 1) (call return 1)
+ (const 1) (bind (x #f 0)) (lexical #t #f set 0)
+ (lexical #t #f ref 0) (call null? 1) (call return 1)
(unbind))))
(with-test-prefix "lexical sets"
(assert-tree-il->glil
(let (x) (y) ((const 1)) (set! (lexical x y) (const 2)))
- (program 0 0 0 1 ()
- (const 1) (bind (x external 0)) (external set 0 0)
- (const 2) (external set 0 0) (void) (call return 1)
+ (program 0 0 1 0 ()
+ (const 1) (bind (x #t 0)) (lexical #t #t box 0)
+ (const 2) (lexical #t #t set 0) (void) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f)))
- (program 0 0 0 1 ()
- (const 1) (bind (x external 0)) (external set 0 0)
- (const 2) (external set 0 0) (const #f) (call return 1)
+ (program 0 0 1 0 ()
+ (const 1) (bind (x #t 0)) (lexical #t #t box 0)
+ (const 2) (lexical #t #t set 0) (const #f) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1))
(apply (primitive null?) (set! (lexical x y) (const 2))))
- (program 0 0 0 1 ()
- (const 1) (bind (x external 0)) (external set 0 0)
- (const 2) (external set 0 0) (void) (call null? 1) (call return 1)
+ (program 0 0 1 0 ()
+ (const 1) (bind (x #t 0)) (lexical #t #t box 0)
+ (const 2) (lexical #t #t set 0) (void) (call null? 1) (call return 1)
(unbind))))
(with-test-prefix "module refs"
(lambda (x) (y) () (const 2))
(program 0 0 0 0 ()
(program 1 0 0 0 ()
- (bind (x local 0))
+ (bind (x #f 0))
(const 2) (call return 1))
(call return 1)))
(lambda (x x1) (y y1) () (const 2))
(program 0 0 0 0 ()
(program 2 0 0 0 ()
- (bind (x local 0) (x1 local 1))
+ (bind (x #f 0) (x1 #f 1))
(const 2) (call return 1))
(call return 1)))
(lambda x y () (const 2))
(program 0 0 0 0 ()
(program 1 1 0 0 ()
- (bind (x local 0))
+ (bind (x #f 0))
(const 2) (call return 1))
(call return 1)))
(lambda (x . x1) (y . y1) () (const 2))
(program 0 0 0 0 ()
(program 2 1 0 0 ()
- (bind (x local 0) (x1 local 1))
+ (bind (x #f 0) (x1 #f 1))
(const 2) (call return 1))
(call return 1)))
(lambda (x . x1) (y . y1) () (lexical x y))
(program 0 0 0 0 ()
(program 2 1 0 0 ()
- (bind (x local 0) (x1 local 1))
- (local ref 0) (call return 1))
+ (bind (x #f 0) (x1 #f 1))
+ (lexical #t #f ref 0) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda (x . x1) (y . y1) () (lexical x1 y1))
(program 0 0 0 0 ()
(program 2 1 0 0 ()
- (bind (x local 0) (x1 local 1))
- (local ref 1) (call return 1))
+ (bind (x #f 0) (x1 #f 1))
+ (lexical #t #f ref 1) (call return 1))
(call return 1)))
(assert-tree-il->glil
(lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
(program 0 0 0 0 ()
- (program 1 0 0 1 ()
- (bind (x external 0))
- (local ref 0) (external set 0 0)
+ (program 1 0 0 0 ()
+ (bind (x #f 0))
(program 1 0 0 0 ()
- (bind (y local 0))
- (external ref 1 0) (call return 1))
+ (bind (y #f 0))
+ (lexical #f #f ref 0) (call return 1))
+ (lexical #t #f ref 0)
+ (call vector 1)
+ (call make-closure2 2)
(call return 1))
(call return 1))))
(let (a) (b) ((const 2))
(lexical a b))))
(program 0 0 1 0 ()
- (const 1) (bind (x local 0)) (local set 0)
- (local ref 0) (branch br-if-not ,l1)
- (local ref 0) (call return 1)
+ (const 1) (bind (x #f 0)) (lexical #t #f set 0)
+ (lexical #t #f ref 0) (branch br-if-not ,l1)
+ (lexical #t #f ref 0) (call return 1)
(label ,l2)
- (const 2) (bind (a local 0)) (local set 0)
- (local ref 0) (call return 1)
+ (const 2) (bind (a #f 0)) (lexical #t #f set 0)
+ (lexical #t #f ref 0) (call return 1)
(unbind)
(unbind))
(eq? l1 l2))
(let (a) (b) ((const 2))
(lexical x y))))
(program 0 0 2 0 ()
- (const 1) (bind (x local 0)) (local set 0)
- (local ref 0) (branch br-if-not ,l1)
- (local ref 0) (call return 1)
+ (const 1) (bind (x #f 0)) (lexical #t #f set 0)
+ (lexical #t #f ref 0) (branch br-if-not ,l1)
+ (lexical #t #f ref 0) (call return 1)
(label ,l2)
- (const 2) (bind (a local 1)) (local set 1)
- (local ref 0) (call return 1)
+ (const 2) (bind (a #f 1)) (lexical #t #f set 1)
+ (lexical #t #f ref 0) (call return 1)
(unbind)
(unbind))
(eq? l1 l2)))
HCoop / bpt / guile.git / commitdiff