From 66d3e9a32c2da4eedb3f316e0dcffe92e6631f87 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Jul 2009 17:00:56 +0200 Subject: [PATCH] compile lexical variable access and closure creation to the new ops * module/language/glil.scm (): New GLIL type, , which will subsume other lexical types. * module/language/glil/compile-assembly.scm: Compile . (make-open-binding): Change the interpretation of the second argument -- instead of indicating an "external" var, it now indicates a boxed var. (open-binding): Adapt to new glil-bind format. * module/language/tree-il/analyze.scm: Add a lot more docs. (analyze-lexicals): Change the allocation algorithm and output format to allow the tree-il->glil compiler to capture free variables appropriately and to reference bound variables in boxes if necessary. Amply documented. * module/language/tree-il/compile-glil.scm (compile-glil): Compile lexical variable access to . Emit variable capture and closure creation code here, instead of leaving that task to the GLIL->assembly compiler. * test-suite/tests/tree-il.test: Update expected code emission. --- module/language/glil.scm | 11 +- module/language/glil/compile-assembly.scm | 23 +- module/language/tree-il/analyze.scm | 568 ++++++++++++---------- module/language/tree-il/compile-glil.scm | 164 ++++--- test-suite/tests/tree-il.test | 76 +-- 5 files changed, 461 insertions(+), 381 deletions(-) rewrite module/language/tree-il/analyze.scm (67%) diff --git a/module/language/glil.scm b/module/language/glil.scm index 38b915f9e..4dff8178b 100644 --- a/module/language/glil.scm +++ b/module/language/glil.scm @@ -1,6 +1,6 @@ ;;; Guile Low Intermediate Language -;; Copyright (C) 2001 Free Software Foundation, Inc. +;; Copyright (C) 2001, 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 @@ -49,6 +49,9 @@ make-glil-external glil-external? glil-external-op glil-external-depth glil-external-index + make-glil-lexical glil-lexical? + glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index + make-glil-toplevel glil-toplevel? glil-toplevel-op glil-toplevel-name @@ -85,6 +88,7 @@ ;; Variables ( op index) ( op depth index) + ( local? boxed? op index) ( op name) ( op mod name public?) ;; Controls @@ -122,6 +126,7 @@ ((const ,obj) (make-glil-const obj)) ((local ,op ,index) (make-glil-local op index)) ((external ,op ,depth ,index) (make-glil-external op depth index)) + ((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index)) ((toplevel ,op ,name) (make-glil-toplevel op name)) ((module public ,op ,mod ,name) (make-glil-module op mod name #t)) ((module private ,op ,mod ,name) (make-glil-module op mod name #f)) @@ -144,10 +149,10 @@ (() `(void)) (( obj) `(const ,obj)) ;; variables - (( op index) - `(local ,op ,index)) (( op depth index) `(external ,op ,depth ,index)) + (( local? boxed? op index) + `(lexical ,local? ,boxed? ,op ,index)) (( op name) `(toplevel ,op ,name)) (( op mod name public?) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index 0b92a4e7d..b2ea8dcab 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -78,8 +78,8 @@ (make-glil-call 'return 1)))))) ;; A functional stack of names of live variables. -(define (make-open-binding name ext? index) - (list name ext? index)) +(define (make-open-binding name boxed? index) + (list name boxed? index)) (define (make-closed-binding open-binding start end) (make-binding (car open-binding) (cadr open-binding) (caddr open-binding) start end)) @@ -89,8 +89,8 @@ (map (lambda (v) (pmatch v - ((,name local ,i) (make-open-binding name #f i)) - ((,name external ,i) (make-open-binding name #t i)) + ((,name ,boxed? ,i) + (make-open-binding name boxed? i)) (else (error "unknown binding type" v)))) vars) (car bindings)) @@ -257,6 +257,21 @@ `((external-ref ,(+ n index))) `((external-set ,(+ n index)))))))) + (( local? boxed? op index) + (emit-code + `((,(if local? + (case op + ((ref) (if boxed? 'local-boxed-ref 'local-ref)) + ((set) (if boxed? 'local-boxed-set 'local-set)) + ((box) 'box) + ((empty-box) 'empty-box) + (else (error "what" op))) + (case op + ((ref) (if boxed? 'closure-boxed-ref 'closure-ref)) + ((set) (if boxed? 'closure-boxed-set (error "what." glil))) + (else (error "what" op)))) + ,index)))) + (( op name) (case op ((ref set) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm dissimilarity index 67% index 976807718..4ed796c03 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -1,258 +1,310 @@ -;;; 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 - (( proc args) - (step proc) (for-each step args)) - - (( test then else) - (step test) (step then) (step else)) - - (( 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)))) - - (( name gensym exp) - (step exp) - (if (not (hashq-ref heaps gensym)) - (hashq-set! heaps gensym (find-heap gensym parent)))) - - (( mod name public? exp) - (step exp)) - - (( name exp) - (step exp)) - - (( name exp) - (step exp)) - - (( exps) - (for-each step exps)) - - (( 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)))) - - (( vars vals body) - (for-each step vals) - (hashq-set! bindings parent - (append (reverse vars) (hashq-ref bindings parent))) - (step body)) - - (( vars vals body) - (hashq-set! bindings parent - (append (reverse vars) (hashq-ref bindings parent))) - (for-each step vals) - (step body)) - - (( 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 - (( proc args) - (apply max (recur proc) (map recur args))) - - (( test then else) - (max (recur test) (recur then) (recur else))) - - (( name gensym exp) - (recur exp)) - - (( mod name public? exp) - (recur exp)) - - (( name exp) - (recur exp)) - - (( name exp) - (recur exp)) - - (( exps) - (apply max (map recur exps))) - - (( 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) - - (( 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))))))))))) - - (( 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)))))))) - - (( 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 + (( proc args) + (apply lset-union eq? (step proc) (map step args))) + + (( test then else) + (lset-union eq? (step test) (step then) (step else))) + + (( name gensym) + (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) + (list gensym)) + + (( name gensym exp) + (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) + (hashq-set! assigned gensym #t) + (lset-adjoin eq? (step exp) gensym)) + + (( mod name public? exp) + (step exp)) + + (( name exp) + (step exp)) + + (( name exp) + (step exp)) + + (( exps) + (apply lset-union eq? (map step exps))) + + (( 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))) + + (( 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)) + + (( 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)) + + (( 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 + (( proc args) + (apply max (recur proc) (map recur args))) + + (( test then else) + (max (recur test) (recur then) (recur else))) + + (( name gensym exp) + (recur exp)) + + (( mod name public? exp) + (recur exp)) + + (( name exp) + (recur exp)) + + (( name exp) + (recur exp)) + + (( exps) + (apply max (map recur exps))) + + (( 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) + + (( 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))))))))) + + (( 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)))))) + + (( 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) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index e0df038d8..29f4683c1 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -20,6 +20,7 @@ (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) @@ -34,8 +35,12 @@ ;; 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)) @@ -45,7 +50,7 @@ (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))))) @@ -131,20 +136,19 @@ (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 '())) @@ -155,7 +159,7 @@ (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)) @@ -166,31 +170,27 @@ (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) @@ -424,27 +424,21 @@ (( 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))))) + (( 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))) @@ -495,39 +489,52 @@ (emit-code #f (make-glil-call 'return 1))))) (() - (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))))))) + (( 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))) (( 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))) @@ -548,16 +555,15 @@ (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)))))))))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index ec410b52b..21efa8e31 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -129,45 +129,45 @@ (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" @@ -322,7 +322,7 @@ (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))) @@ -330,7 +330,7 @@ (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))) @@ -338,7 +338,7 @@ (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))) @@ -346,7 +346,7 @@ (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))) @@ -354,27 +354,29 @@ (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)))) @@ -399,12 +401,12 @@ (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)) @@ -416,12 +418,12 @@ (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))) -- 2.20.1