mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-21 20:20:24 +02:00
Code Activity

compile lexical variable access and closure creation to the new ops

Browse source 
* module/language/glil.scm (<glil>): New GLIL type, <glil-lexical>,
  which will subsume other lexical types.
* module/language/glil/compile-assembly.scm: Compile <glil-lexical>.
  (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 <glil-lexical>. 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.
This commit is contained in:
Andy Wingo 2009-07-23 17:00:56 +02:00
parent 8d90b35656
commit 66d3e9a32c
5 changed files with 374 additions and 294 deletions
Download patch file Download diff file Expand all files Collapse all files

11
module/language/glil.scm
View file

@ -1,6 +1,6 @@
;;; Guile Low Intermediate Language ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -49,6 +49,9 @@
<glil-external> make-glil-external glil-external? <glil-external> make-glil-external glil-external?
glil-external-op glil-external-depth glil-external-index glil-external-op glil-external-depth glil-external-index
<glil-lexical> make-glil-lexical glil-lexical?
glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index
<glil-toplevel> make-glil-toplevel glil-toplevel? <glil-toplevel> make-glil-toplevel glil-toplevel?
glil-toplevel-op glil-toplevel-name glil-toplevel-op glil-toplevel-name
@ -85,6 +88,7 @@
;; Variables ;; Variables
(<glil-local> op index) (<glil-local> op index)
(<glil-external> op depth index) (<glil-external> op depth index)
(<glil-lexical> local? boxed? op index)
(<glil-toplevel> op name) (<glil-toplevel> op name)
(<glil-module> op mod name public?) (<glil-module> op mod name public?)
;; Controls ;; Controls
@ -122,6 +126,7 @@
((const ,obj) (make-glil-const obj)) ((const ,obj) (make-glil-const obj))
((local ,op ,index) (make-glil-local op index)) ((local ,op ,index) (make-glil-local op index))
((external ,op ,depth ,index) (make-glil-external op depth 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)) ((toplevel ,op ,name) (make-glil-toplevel op name))
((module public ,op ,mod ,name) (make-glil-module op mod name #t)) ((module public ,op ,mod ,name) (make-glil-module op mod name #t))
((module private ,op ,mod ,name) (make-glil-module op mod name #f)) ((module private ,op ,mod ,name) (make-glil-module op mod name #f))
@ -144,10 +149,10 @@
((<glil-void>) `(void)) ((<glil-void>) `(void))
((<glil-const> obj) `(const ,obj)) ((<glil-const> obj) `(const ,obj))
;; variables ;; variables
((<glil-local> op index)
`(local ,op ,index))
((<glil-external> op depth index) ((<glil-external> op depth index)
`(external ,op ,depth ,index)) `(external ,op ,depth ,index))
((<glil-lexical> local? boxed? op index)
`(lexical ,local? ,boxed? ,op ,index))
((<glil-toplevel> op name) ((<glil-toplevel> op name)
`(toplevel ,op ,name)) `(toplevel ,op ,name))
((<glil-module> op mod name public?) ((<glil-module> op mod name public?)

23
module/language/glil/compile-assembly.scm
View file

@ -78,8 +78,8 @@
(make-glil-call 'return 1)))))) (make-glil-call 'return 1))))))
;; A functional stack of names of live variables. ;; A functional stack of names of live variables.
(define (make-open-binding name ext? index) (define (make-open-binding name boxed? index)
(list name ext? index)) (list name boxed? index))
(define (make-closed-binding open-binding start end) (define (make-closed-binding open-binding start end)
(make-binding (car open-binding) (cadr open-binding) (make-binding (car open-binding) (cadr open-binding)
(caddr open-binding) start end)) (caddr open-binding) start end))
@ -89,8 +89,8 @@
(map (map
(lambda (v) (lambda (v)
(pmatch v (pmatch v
((,name local ,i) (make-open-binding name #f i)) ((,name ,boxed? ,i)
((,name external ,i) (make-open-binding name #t i)) (make-open-binding name boxed? i))
(else (error "unknown binding type" v)))) (else (error "unknown binding type" v))))
vars) vars)
(car bindings)) (car bindings))
@ -257,6 +257,21 @@
`((external-ref ,(+ n index))) `((external-ref ,(+ n index)))
`((external-set ,(+ n index)))))))) `((external-set ,(+ n index))))))))
((<glil-lexical> 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))))
((<glil-toplevel> op name) ((<glil-toplevel> op name)
(case op (case op
((ref set) ((ref set)

392
module/language/tree-il/analyze.scm
View file

@ -19,14 +19,37 @@
;;; Code: ;;; Code:
(define-module (language tree-il analyze) (define-module (language tree-il analyze)
#:use-module (srfi srfi-1)
#:use-module (system base syntax) #:use-module (system base syntax)
#:use-module (language tree-il) #:use-module (language tree-il)
#:export (analyze-lexicals)) #:export (analyze-lexicals))
;; allocation: the process of assigning a type and index to each var ;; Allocation is the process of assigning storage locations for lexical
;; a var is external if it is heaps; assigning index is easy ;; variables. A lexical variable has a distinct "address", or storage
;; args are assigned in order ;; location, for each procedure in which it is referenced.
;; locals are indexed as their linear position in the binding path ;;
;; 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 (0 1)
;; (let (2 3) ...) ;; (let (2 3) ...)
;; (let (2) ...)) ;; (let (2) ...))
@ -48,49 +71,67 @@
;; case. A proper solution would be some sort of liveness analysis, and ;; case. A proper solution would be some sort of liveness analysis, and
;; not our linear allocation algorithm. ;; not our linear allocation algorithm.
;; ;;
;; allocation: ;; Closure variables are captured when a closure is created, and stored
;; sym -> (local . index) | (heap level . index) ;; in a vector. Each closure variable has a unique index into that
;; lambda -> (nlocs . nexts) ;; 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) (define (analyze-lexicals x)
;; parents: lambda -> parent ;; bound-vars: lambda -> (sym ...)
;; useful when we see a closed-over var, so we can calculate its ;; all identifiers bound within a lambda
;; coordinates (depth and index). ;; free-vars: lambda -> (sym ...)
;; bindings: lambda -> (sym ...) ;; all identifiers referenced in a lambda, but not bound
;; useful for two reasons: one, so we know how much space to allocate ;; NB, this includes identifiers referenced by contained lambdas
;; when we go into a lambda; and two, so that we know when to stop, ;; assigned: sym -> #t
;; when looking for closed-over vars. ;; variables that are assigned
;; heaps: sym -> lambda
;; allows us to heapify vars in an O(1) fashion
;; refcounts: sym -> count ;; refcounts: sym -> count
;; allows us to detect the or-expansion an O(1) time ;; allows us to detect the or-expansion in O(1) time
(define (find-heap sym parent) ;; returns variables referenced in expr
;; fixme: check displaced lexicals here? (define (analyze! x proc)
(if (memq sym (hashq-ref bindings parent)) (define (step y) (analyze! y proc))
parent (define (recur x new-proc) (analyze! x new-proc))
(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 (record-case x
((<application> proc args) ((<application> proc args)
(step proc) (for-each step args)) (apply lset-union eq? (step proc) (map step args)))
((<conditional> test then else) ((<conditional> test then else)
(step test) (step then) (step else)) (lset-union eq? (step test) (step then) (step else)))
((<lexical-ref> name gensym) ((<lexical-ref> name gensym)
(hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
(if (and (not (memq gensym (hashq-ref bindings parent))) (list gensym))
(not (hashq-ref heaps gensym)))
(hashq-set! heaps gensym (find-heap gensym parent))))
((<lexical-set> name gensym exp) ((<lexical-set> name gensym exp)
(step exp) (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
(if (not (hashq-ref heaps gensym)) (hashq-set! assigned gensym #t)
(hashq-set! heaps gensym (find-heap gensym parent)))) (lset-adjoin eq? (step exp) gensym))
((<module-set> mod name public? exp) ((<module-set> mod name public? exp)
(step exp)) (step exp))
@ -102,157 +143,168 @@
(step exp)) (step exp))
((<sequence> exps) ((<sequence> exps)
(for-each step exps)) (apply lset-union eq? (map step exps)))
((<lambda> vars meta body) ((<lambda> vars meta body)
(hashq-set! parents x parent) (let ((locally-bound (let rev* ((vars vars) (out '()))
(hashq-set! bindings x (cond ((null? vars) out)
(let rev* ((vars vars) (out '())) ((pair? vars) (rev* (cdr vars)
(cond ((null? vars) out) (cons (car vars) out)))
((pair? vars) (rev* (cdr vars) (else (cons vars out))))))
(cons (car vars) out))) (hashq-set! bound-vars x locally-bound)
(else (cons vars out))))) (let* ((referenced (recur body x))
(recur body x) (free (lset-difference eq? referenced locally-bound))
(hashq-set! bindings x (reverse! (hashq-ref bindings x)))) (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) ((<let> vars vals body)
(for-each step vals) (hashq-set! bound-vars proc
(hashq-set! bindings parent (append (reverse vars) (hashq-ref bound-vars proc)))
(append (reverse vars) (hashq-ref bindings parent))) (lset-difference eq?
(step body)) (apply lset-union eq? (step body) (map step vals))
vars))
((<letrec> vars vals body) ((<letrec> vars vals body)
(hashq-set! bindings parent (hashq-set! bound-vars proc
(append (reverse vars) (hashq-ref bindings parent))) (append (reverse vars) (hashq-ref bound-vars proc)))
(for-each step vals) (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars)
(step body)) (lset-difference eq?
(apply lset-union eq? (step body) (map step vals))
vars))
((<let-values> vars exp body) ((<let-values> vars exp body)
(hashq-set! bindings parent (hashq-set! bound-vars proc
(let lp ((out (hashq-ref bindings parent)) (in vars)) (let lp ((out (hashq-ref bound-vars proc)) (in vars))
(if (pair? in) (if (pair? in)
(lp (cons (car in) out) (cdr in)) (lp (cons (car in) out) (cdr in))
(if (null? in) out (cons in out))))) (if (null? in) out (cons in out)))))
(step exp) (lset-difference eq?
(step body)) (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)))
(else #f))) ((<conditional> test then else)
(max (recur test) (recur then) (recur else)))
(define (allocate-heap! binder) ((<lexical-set> name gensym exp)
(hashq-set! heap-indexes binder (recur exp))
(1+ (hashq-ref heap-indexes binder -1))))
((<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)
(define (allocate! x level n) ((<let> vars vals body)
(define (recur y) (allocate! y level n)) (let ((nmax (apply max (map recur vals))))
(record-case x (cond
((<application> proc args) ;; the `or' hack
(apply max (recur proc) (map recur args))) ((and (conditional? body)
(= (length vars) 1)
((<conditional> test then else) (let ((v (car vars)))
(max (recur test) (recur then) (recur else))) (and (not (hashq-ref assigned v))
(= (hashq-ref refcounts v 0) 2)
((<lexical-set> name gensym exp) (lexical-ref? (conditional-test body))
(recur exp)) (eq? (lexical-ref-gensym (conditional-test body)) v)
(lexical-ref? (conditional-then body))
((<module-set> mod name public? exp) (eq? (lexical-ref-gensym (conditional-then body)) v))))
(recur exp)) (hashq-set! allocation (car vars)
(make-hashq proc `(#t #f . ,n)))
((<toplevel-set> name exp) ;; the 1+ for this var
(recur exp)) (max nmax (1+ n) (allocate! (conditional-else body) proc n)))
(else
((<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)) (let lp ((vars vars) (n n))
(if (null? vars) (if (null? vars)
(max nmax (allocate! body level n)) (max nmax (allocate! body proc n))
(let ((v (if (pair? vars) (car vars) vars))) (let ((v (car vars)))
(let ((binder (hashq-ref heaps v))) (hashq-set!
(hashq-set! allocation v
allocation v (make-hashq proc
(if binder `(#t ,(hashq-ref assigned v) . ,n)))
(cons* 'heap level (allocate-heap! binder)) (lp (cdr vars) (1+ n)))))))))
(cons 'stack n)))
(lp (if (pair? vars) (cdr vars) '()) ((<letrec> vars vals body)
(if binder n (1+ n))))))))) (let lp ((vars vars) (n n))
(if (null? vars)
(else n))) (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))))))
(define parents (make-hash-table)) ((<let-values> vars exp body)
(define bindings (make-hash-table)) (let ((nmax (recur exp)))
(define heaps (make-hash-table)) (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 refcounts (make-hash-table))
(define allocation (make-hash-table)) (define allocation (make-hash-table))
(define heap-indexes (make-hash-table))
(analyze! x #f)
(analyze! x #f -1) (allocate! x #f 0)
(allocate! x -1 0)
allocation) allocation)

166
module/language/tree-il/compile-glil.scm
View file

@ -20,6 +20,7 @@
(define-module (language tree-il compile-glil) (define-module (language tree-il compile-glil)
#:use-module (system base syntax) #:use-module (system base syntax)
#:use-module (system base pmatch)
#:use-module (ice-9 receive) #:use-module (ice-9 receive)
#:use-module (language glil) #:use-module (language glil)
#:use-module (system vm instruction) #:use-module (system vm instruction)
@ -34,8 +35,12 @@
;; basic degenerate-case reduction ;; basic degenerate-case reduction
;; allocation: ;; allocation:
;; sym -> (local . index) | (heap level . index) ;; sym -> {lambda -> address}
;; lambda -> (nlocs . nexts) ;; 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 *comp-module* (make-fluid))
@ -45,7 +50,7 @@
(allocation (analyze-lexicals x))) (allocation (analyze-lexicals x)))
(with-fluid* *comp-module* (or (and e (car e)) (current-module)) (with-fluid* *comp-module* (or (and e (car e)) (current-module))
(lambda () (lambda ()
(values (flatten-lambda x -1 allocation) (values (flatten-lambda x allocation)
(and e (cons (car e) (cddr e))) (and e (cons (car e) (cddr e)))
e))))) e)))))
@ -131,20 +136,19 @@
(define (make-label) (gensym ":L")) (define (make-label) (gensym ":L"))
(define (vars->bind-list ids vars allocation) (define (vars->bind-list ids vars allocation proc)
(map (lambda (id v) (map (lambda (id v)
(let ((loc (hashq-ref allocation v))) (pmatch (hashq-ref (hashq-ref allocation v) proc)
(case (car loc) ((#t ,boxed? . ,n)
((stack) (list id 'local (cdr loc))) (list id boxed? n))
((heap) (list id 'external (cddr loc))) (,x (error "badness" x))))
(else (error "badness" id v loc)))))
ids ids
vars)) vars))
(define (emit-bindings src ids vars allocation emit-code) (define (emit-bindings src ids vars allocation proc emit-code)
(if (pair? vars) (if (pair? vars)
(emit-code src (make-glil-bind (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) (define (with-output-to-code proc)
(let ((out '())) (let ((out '()))
@ -155,7 +159,7 @@
(proc emit-code) (proc emit-code)
(reverse out))) (reverse out)))
(define (flatten-lambda x level allocation) (define (flatten-lambda x allocation)
(receive (ids vars nargs nrest) (receive (ids vars nargs nrest)
(let lp ((ids (lambda-names x)) (vars (lambda-vars x)) (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
(oids '()) (ovars '()) (n 0)) (oids '()) (ovars '()) (n 0))
@ -166,31 +170,27 @@
(else (values (reverse (cons ids oids)) (else (values (reverse (cons ids oids))
(reverse (cons vars ovars)) (reverse (cons vars ovars))
(1+ n) 1)))) (1+ n) 1))))
(let ((nlocs (car (hashq-ref allocation x))) (let ((nlocs (car (hashq-ref allocation x))))
(nexts (cdr (hashq-ref allocation x))))
(make-glil-program (make-glil-program
nargs nrest nlocs nexts (lambda-meta x) nargs nrest nlocs 0 (lambda-meta x)
(with-output-to-code (with-output-to-code
(lambda (emit-code) (lambda (emit-code)
;; write bindings and source debugging info ;; 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) (if (lambda-src x)
(emit-code #f (make-glil-source (lambda-src x)))) (emit-code #f (make-glil-source (lambda-src x))))
;; box args if necessary
;; copy args to the heap if necessary (for-each
(let lp ((in vars) (n 0)) (lambda (v)
(if (not (null? in)) (pmatch (hashq-ref (hashq-ref allocation v) x)
(let ((loc (hashq-ref allocation (car in)))) ((#t #t . ,n)
(case (car loc) (emit-code #f (make-glil-lexical #t #f 'ref n))
((heap) (emit-code #f (make-glil-lexical #t #t 'box n)))))
(emit-code #f (make-glil-local 'ref n)) vars)
(emit-code #f (make-glil-external 'set 0 (cddr loc)))))
(lp (cdr in) (1+ n)))))
;; and here, here, dear reader: we compile. ;; 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) (define (emit-label label)
(emit-code #f (make-glil-label label))) (emit-code #f (make-glil-label label)))
(define (emit-branch src inst label) (define (emit-branch src inst label)
@ -424,27 +424,21 @@
((<lexical-ref> src name gensym) ((<lexical-ref> src name gensym)
(case context (case context
((push vals tail) ((push vals tail)
(let ((loc (hashq-ref allocation gensym))) (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
(case (car loc) ((,local? ,boxed? . ,index)
((stack) (emit-code src (make-glil-lexical local? boxed? 'ref index)))
(emit-code src (make-glil-local 'ref (cdr loc)))) (,loc
((heap) (error "badness" x loc)))))
(emit-code src (make-glil-external (case context
'ref (- level (cadr loc)) (cddr loc)))) ((tail) (emit-code #f (make-glil-call 'return 1)))))
(else (error "badness" x loc)))
(if (eq? context 'tail)
(emit-code #f (make-glil-call 'return 1)))))))
((<lexical-set> src name gensym exp) ((<lexical-set> src name gensym exp)
(comp-push exp) (comp-push exp)
(let ((loc (hashq-ref allocation gensym))) (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
(case (car loc) ((,local? ,boxed? . ,index)
((stack) (emit-code src (make-glil-lexical local? boxed? 'set index)))
(emit-code src (make-glil-local 'set (cdr loc)))) (,loc
((heap) (error "badness" x loc)))
(emit-code src (make-glil-external
'set (- level (cadr loc)) (cddr loc))))
(else (error "badness" x loc))))
(case context (case context
((push vals) ((push vals)
(emit-code #f (make-glil-void))) (emit-code #f (make-glil-void)))
@ -495,39 +489,52 @@
(emit-code #f (make-glil-call 'return 1))))) (emit-code #f (make-glil-call 'return 1)))))
((<lambda>) ((<lambda>)
(case context (let ((free-locs (cdr (hashq-ref allocation x))))
((push vals) (case context
(emit-code #f (flatten-lambda x level allocation))) ((push vals tail)
((tail) (emit-code #f (flatten-lambda x allocation))
(emit-code #f (flatten-lambda x level allocation)) (if (not (null? free-locs))
(emit-code #f (make-glil-call 'return 1))))) (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) ((<let> src names vars vals body)
(for-each comp-push vals) (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) (for-each (lambda (v)
(let ((loc (hashq-ref allocation v))) (pmatch (hashq-ref (hashq-ref allocation v) proc)
(case (car loc) ((#t #f . ,n)
((stack) (emit-code src (make-glil-lexical #t #f 'set n)))
(emit-code src (make-glil-local 'set (cdr loc)))) ((#t #t . ,n)
((heap) (emit-code src (make-glil-lexical #t #t 'box n)))
(emit-code src (make-glil-external 'set 0 (cddr loc)))) (,loc (error "badness" x loc))))
(else (error "badness" x loc)))))
(reverse vars)) (reverse vars))
(comp-tail body) (comp-tail body)
(emit-code #f (make-glil-unbind))) (emit-code #f (make-glil-unbind)))
((<letrec> src names vars vals body) ((<letrec> src names vars vals body)
(for-each comp-push vals)
(emit-bindings src names vars allocation emit-code)
(for-each (lambda (v) (for-each (lambda (v)
(let ((loc (hashq-ref allocation v))) (pmatch (hashq-ref (hashq-ref allocation v) proc)
(case (car loc) ((#t #t . ,n)
((stack) (emit-code src (make-glil-lexical #t #t 'empty-box n)))
(emit-code src (make-glil-local 'set (cdr loc)))) (,loc (error "badness" x loc))))
((heap) vars)
(emit-code src (make-glil-external 'set 0 (cddr loc)))) (for-each comp-push vals)
(else (error "badness" x loc))))) (emit-bindings src names vars allocation proc emit-code)
(for-each (lambda (v)
(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)) (reverse vars))
(comp-tail body) (comp-tail body)
(emit-code #f (make-glil-unbind))) (emit-code #f (make-glil-unbind)))
@ -548,16 +555,15 @@
(emit-code #f (make-glil-const 1)) (emit-code #f (make-glil-const 1))
(emit-label MV) (emit-label MV)
(emit-code src (make-glil-mv-bind (emit-code src (make-glil-mv-bind
(vars->bind-list names vars allocation) (vars->bind-list names vars allocation proc)
rest?)) rest?))
(for-each (lambda (v) (for-each (lambda (v)
(let ((loc (hashq-ref allocation v))) (pmatch (hashq-ref (hashq-ref allocation v) proc)
(case (car loc) ((#t #f . ,n)
((stack) (emit-code src (make-glil-lexical #t #f 'set n)))
(emit-code src (make-glil-local 'set (cdr loc)))) ((#t #t . ,n)
((heap) (emit-code src (make-glil-lexical #t #t 'box n)))
(emit-code src (make-glil-external 'set 0 (cddr loc)))) (,loc (error "badness" x loc))))
(else (error "badness" x loc)))))
(reverse vars)) (reverse vars))
(comp-tail body) (comp-tail body)
(emit-code #f (make-glil-unbind)))))))))) (emit-code #f (make-glil-unbind))))))))))

76
test-suite/tests/tree-il.test
View file

@ -129,45 +129,45 @@
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (lexical x y)) (let (x) (y) ((const 1)) (lexical x y))
(program 0 0 1 0 () (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)
(local ref 0) (call return 1) (lexical #t #f ref 0) (call return 1)
(unbind))) (unbind)))
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f))) (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
(program 0 0 1 0 () (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) (const #f) (call return 1)
(unbind))) (unbind)))
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
(program 0 0 1 0 () (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)
(local ref 0) (call null? 1) (call return 1) (lexical #t #f ref 0) (call null? 1) (call return 1)
(unbind)))) (unbind))))
(with-test-prefix "lexical sets" (with-test-prefix "lexical sets"
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (set! (lexical x y) (const 2))) (let (x) (y) ((const 1)) (set! (lexical x y) (const 2)))
(program 0 0 0 1 () (program 0 0 1 0 ()
(const 1) (bind (x external 0)) (external set 0 0) (const 1) (bind (x #t 0)) (lexical #t #t box 0)
(const 2) (external set 0 0) (void) (call return 1) (const 2) (lexical #t #t set 0) (void) (call return 1)
(unbind))) (unbind)))
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f))) (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f)))
(program 0 0 0 1 () (program 0 0 1 0 ()
(const 1) (bind (x external 0)) (external set 0 0) (const 1) (bind (x #t 0)) (lexical #t #t box 0)
(const 2) (external set 0 0) (const #f) (call return 1) (const 2) (lexical #t #t set 0) (const #f) (call return 1)
(unbind))) (unbind)))
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (let (x) (y) ((const 1))
(apply (primitive null?) (set! (lexical x y) (const 2)))) (apply (primitive null?) (set! (lexical x y) (const 2))))
(program 0 0 0 1 () (program 0 0 1 0 ()
(const 1) (bind (x external 0)) (external set 0 0) (const 1) (bind (x #t 0)) (lexical #t #t box 0)
(const 2) (external set 0 0) (void) (call null? 1) (call return 1) (const 2) (lexical #t #t set 0) (void) (call null? 1) (call return 1)
(unbind)))) (unbind))))
(with-test-prefix "module refs" (with-test-prefix "module refs"
@ -322,7 +322,7 @@
(lambda (x) (y) () (const 2)) (lambda (x) (y) () (const 2))
(program 0 0 0 0 () (program 0 0 0 0 ()
(program 1 0 0 0 () (program 1 0 0 0 ()
(bind (x local 0)) (bind (x #f 0))
(const 2) (call return 1)) (const 2) (call return 1))
(call return 1))) (call return 1)))
@ -330,7 +330,7 @@
(lambda (x x1) (y y1) () (const 2)) (lambda (x x1) (y y1) () (const 2))
(program 0 0 0 0 () (program 0 0 0 0 ()
(program 2 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)) (const 2) (call return 1))
(call return 1))) (call return 1)))
@ -338,7 +338,7 @@
(lambda x y () (const 2)) (lambda x y () (const 2))
(program 0 0 0 0 () (program 0 0 0 0 ()
(program 1 1 0 0 () (program 1 1 0 0 ()
(bind (x local 0)) (bind (x #f 0))
(const 2) (call return 1)) (const 2) (call return 1))
(call return 1))) (call return 1)))
@ -346,7 +346,7 @@
(lambda (x . x1) (y . y1) () (const 2)) (lambda (x . x1) (y . y1) () (const 2))
(program 0 0 0 0 () (program 0 0 0 0 ()
(program 2 1 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)) (const 2) (call return 1))
(call return 1))) (call return 1)))
@ -354,27 +354,29 @@
(lambda (x . x1) (y . y1) () (lexical x y)) (lambda (x . x1) (y . y1) () (lexical x y))
(program 0 0 0 0 () (program 0 0 0 0 ()
(program 2 1 0 0 () (program 2 1 0 0 ()
(bind (x local 0) (x1 local 1)) (bind (x #f 0) (x1 #f 1))
(local ref 0) (call return 1)) (lexical #t #f ref 0) (call return 1))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x . x1) (y . y1) () (lexical x1 y1)) (lambda (x . x1) (y . y1) () (lexical x1 y1))
(program 0 0 0 0 () (program 0 0 0 0 ()
(program 2 1 0 0 () (program 2 1 0 0 ()
(bind (x local 0) (x1 local 1)) (bind (x #f 0) (x1 #f 1))
(local ref 1) (call return 1)) (lexical #t #f ref 1) (call return 1))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1))) (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
(program 0 0 0 0 () (program 0 0 0 0 ()
(program 1 0 0 1 () (program 1 0 0 0 ()
(bind (x external 0)) (bind (x #f 0))
(local ref 0) (external set 0 0)
(program 1 0 0 0 () (program 1 0 0 0 ()
(bind (y local 0)) (bind (y #f 0))
(external ref 1 0) (call return 1)) (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))
(call return 1)))) (call return 1))))
@ -399,12 +401,12 @@
(let (a) (b) ((const 2)) (let (a) (b) ((const 2))
(lexical a b)))) (lexical a b))))
(program 0 0 1 0 () (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)
(local ref 0) (branch br-if-not ,l1) (lexical #t #f ref 0) (branch br-if-not ,l1)
(local ref 0) (call return 1) (lexical #t #f ref 0) (call return 1)
(label ,l2) (label ,l2)
(const 2) (bind (a local 0)) (local set 0) (const 2) (bind (a #f 0)) (lexical #t #f set 0)
(local ref 0) (call return 1) (lexical #t #f ref 0) (call return 1)
(unbind) (unbind)
(unbind)) (unbind))
(eq? l1 l2)) (eq? l1 l2))
@ -416,12 +418,12 @@
(let (a) (b) ((const 2)) (let (a) (b) ((const 2))
(lexical x y)))) (lexical x y))))
(program 0 0 2 0 () (program 0 0 2 0 ()
(const 1) (bind (x local 0)) (local set 0) (const 1) (bind (x #f 0)) (lexical #t #f set 0)
(local ref 0) (branch br-if-not ,l1) (lexical #t #f ref 0) (branch br-if-not ,l1)
(local ref 0) (call return 1) (lexical #t #f ref 0) (call return 1)
(label ,l2) (label ,l2)
(const 2) (bind (a local 1)) (local set 1) (const 2) (bind (a #f 1)) (lexical #t #f set 1)
(local ref 0) (call return 1) (lexical #t #f ref 0) (call return 1)
(unbind) (unbind)
(unbind)) (unbind))
(eq? l1 l2))) (eq? l1 l2)))