diff options
Diffstat (limited to 'module/language/tree-il')
| -rw-r--r-- | module/language/tree-il/analyze.scm | 617 | ||||
| -rw-r--r-- | module/language/tree-il/compile-glil.scm | 729 | ||||
| -rw-r--r-- | module/language/tree-il/fix-letrec.scm | 240 | ||||
| -rw-r--r-- | module/language/tree-il/inline.scm | 81 | ||||
| -rw-r--r-- | module/language/tree-il/optimize.scm | 35 | ||||
| -rw-r--r-- | module/language/tree-il/primitives.scm | 287 | ||||
| -rw-r--r-- | module/language/tree-il/spec.scm | 42 |
7 files changed, 2031 insertions, 0 deletions
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm new file mode 100644 index 000000000..b93a0bd7e --- /dev/null +++ b/module/language/tree-il/analyze.scm @@ -0,0 +1,617 @@ +;;; 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 (srfi srfi-9) + #:use-module (system base syntax) + #:use-module (system base message) + #:use-module (language tree-il) + #:export (analyze-lexicals + report-unused-variables)) + +;; 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. +;; +;; There is one more complication. Procedures bound by <fix> may, in +;; some cases, be rendered inline to their parent procedure. That is to +;; say, +;; +;; (letrec ((lp (lambda () (lp)))) (lp)) +;; => (fix ((lp (lambda () (lp)))) (lp)) +;; => goto FIX-BODY; LP: goto LP; FIX-BODY: goto LP; +;; ^ jump over the loop ^ the fixpoint lp ^ starting off the loop +;; +;; The upshot is that we don't have to allocate any space for the `lp' +;; closure at all, as it can be rendered inline as a loop. So there is +;; another kind of allocation, "label allocation", in which the +;; procedure is simply a label, placed at the start of the lambda body. +;; The label is the gensym under which the lambda expression is bound. +;; +;; The analyzer checks to see that the label is called with the correct +;; number of arguments. Calls to labels compile to rename + goto. +;; Lambda, the ultimate goto! +;; +;; +;; 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, lexicals that have been +;; translated into labels, and information on what free variables to +;; capture from its lexical parent procedure. +;; +;; That is: +;; +;; sym -> {lambda -> address} +;; lambda -> (nlocs labels . free-locs) +;; +;; address ::= (local? boxed? . index) +;; labels ::= ((sym . lambda-vars) ...) +;; 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 + (define bound-vars (make-hash-table)) + ;; free-vars: lambda -> (sym ...) + ;; all identifiers referenced in a lambda, but not bound + ;; NB, this includes identifiers referenced by contained lambdas + (define free-vars (make-hash-table)) + ;; assigned: sym -> #t + ;; variables that are assigned + (define assigned (make-hash-table)) + ;; refcounts: sym -> count + ;; allows us to detect the or-expansion in O(1) time + (define refcounts (make-hash-table)) + ;; labels: sym -> lambda-vars + ;; for determining if fixed-point procedures can be rendered as + ;; labels. lambda-vars may be an improper list. + (define labels (make-hash-table)) + + ;; returns variables referenced in expr + (define (analyze! x proc labels-in-proc tail? tail-call-args) + (define (step y) (analyze! y proc labels-in-proc #f #f)) + (define (step-tail y) (analyze! y proc labels-in-proc tail? #f)) + (define (step-tail-call y args) (analyze! y proc labels-in-proc #f + (and tail? args))) + (define (recur/labels x new-proc labels) + (analyze! x new-proc (append labels labels-in-proc) #t #f)) + (define (recur x new-proc) (analyze! x new-proc '() tail? #f)) + (record-case x + ((<application> proc args) + (apply lset-union eq? (step-tail-call proc args) + (map step args))) + + ((<conditional> test then else) + (lset-union eq? (step test) (step-tail then) (step-tail else))) + + ((<lexical-ref> name gensym) + (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) + (if (not (and tail-call-args + (memq gensym labels-in-proc) + (let ((args (hashq-ref labels gensym))) + (and (list? args) + (= (length args) (length tail-call-args)))))) + (hashq-set! labels gensym #f)) + (list gensym)) + + ((<lexical-set> name gensym exp) + (hashq-set! assigned gensym #t) + (hashq-set! labels gensym #f) + (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) + (let lp ((exps exps) (ret '())) + (cond ((null? exps) '()) + ((null? (cdr exps)) + (lset-union eq? ret (step-tail (car exps)))) + (else + (lp (cdr exps) (lset-union eq? ret (step (car 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-tail 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-tail body) (map step vals)) + vars)) + + ((<fix> vars vals body) + ;; Try to allocate these procedures as labels. + (for-each (lambda (sym val) (hashq-set! labels sym (lambda-vars val))) + vars vals) + (hashq-set! bound-vars proc + (append (reverse vars) (hashq-ref bound-vars proc))) + ;; Step into subexpressions. + (let* ((var-refs + (map + ;; Since we're trying to label-allocate the lambda, + ;; pretend it's not a closure, and just recurse into its + ;; body directly. (Otherwise, recursing on a closure + ;; that references one of the fix's bound vars would + ;; prevent label allocation.) + (lambda (x) + (record-case x + ((<lambda> (lvars vars) body) + (let ((locally-bound + (let rev* ((lvars lvars) (out '())) + (cond ((null? lvars) out) + ((pair? lvars) (rev* (cdr lvars) + (cons (car lvars) out))) + (else (cons lvars out)))))) + (hashq-set! bound-vars x locally-bound) + ;; recur/labels, the difference from the closure case + (let* ((referenced (recur/labels body x vars)) + (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))))) + vals)) + (vars-with-refs (map cons vars var-refs)) + (body-refs (recur/labels body proc vars))) + (define (delabel-dependents! sym) + (let ((refs (assq-ref vars-with-refs sym))) + (if refs + (for-each (lambda (sym) + (if (hashq-ref labels sym) + (begin + (hashq-set! labels sym #f) + (delabel-dependents! sym)))) + refs)))) + ;; Stepping into the lambdas and the body might have made some + ;; procedures not label-allocatable -- which might have + ;; knock-on effects. For example: + ;; (fix ((a (lambda () (b))) + ;; (b (lambda () a))) + ;; (a)) + ;; As far as `a' is concerned, both `a' and `b' are + ;; label-allocatable. But `b' references `a' not in a proc-tail + ;; position, which makes `a' not label-allocatable. The + ;; knock-on effect is that, when back-propagating this + ;; information to `a', `b' will also become not + ;; label-allocatable, as it is referenced within `a', which is + ;; allocated as a closure. This is a transitive relationship. + (for-each (lambda (sym) + (if (not (hashq-ref labels sym)) + (delabel-dependents! sym))) + vars) + ;; Now lift bound variables with label-allocated lambdas to the + ;; parent procedure. + (for-each + (lambda (sym val) + (if (hashq-ref labels sym) + ;; Remove traces of the label-bound lambda. The free + ;; vars will propagate up via the return val. + (begin + (hashq-set! bound-vars proc + (append (hashq-ref bound-vars val) + (hashq-ref bound-vars proc))) + (hashq-remove! bound-vars val) + (hashq-remove! free-vars val)))) + vars vals) + (lset-difference eq? + (apply lset-union eq? body-refs var-refs) + vars))) + + ((<let-values> vars exp body) + (let ((bound (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)))))) + (hashq-set! bound-vars proc bound) + (lset-difference eq? + (lset-union eq? (step exp) (step-tail body)) + bound))) + + (else '()))) + + ;; allocation: sym -> {lambda -> address} + ;; lambda -> (nlocs labels . free-locs) + (define allocation (make-hash-table)) + + (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))) + (labels (filter cdr + (map (lambda (sym) + (cons sym (hashq-ref labels sym))) + (hashq-ref bound-vars x))))) + ;; set procedure allocations + (hashq-set! allocation x (cons* nlocs labels 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)))))) + + ((<fix> vars vals body) + (let lp ((in vars) (n n)) + (if (null? in) + (let lp ((vars vars) (vals vals) (nmax n)) + (cond + ((null? vars) + (max nmax (allocate! body proc n))) + ((hashq-ref labels (car vars)) + ;; allocate label bindings & body inline to proc + (lp (cdr vars) + (cdr vals) + (record-case (car vals) + ((<lambda> vars body) + (let lp ((vars vars) (n n)) + (if (not (null? vars)) + ;; allocate bindings + (let ((v (if (pair? vars) (car vars) vars))) + (hashq-set! + allocation v + (make-hashq + proc `(#t ,(hashq-ref assigned v) . ,n))) + (lp (if (pair? vars) (cdr vars) '()) (1+ n))) + ;; allocate body + (max nmax (allocate! body proc n)))))))) + (else + ;; allocate closure + (lp (cdr vars) + (cdr vals) + (max nmax (allocate! (car vals) proc n)))))) + + (let ((v (car in))) + (cond + ((hashq-ref assigned v) + (error "fixpoint procedures may not be assigned" x)) + ((hashq-ref labels v) + ;; no binding, it's a label + (lp (cdr in) n)) + (else + ;; allocate closure binding + (hashq-set! allocation v (make-hashq proc `(#t #f . ,n))) + (lp (cdr in) (1+ n)))))))) + + ((<let-values> vars exp body) + (let ((nmax (recur exp))) + (let lp ((vars vars) (n n)) + (cond + ((null? vars) + (max nmax (allocate! body proc n))) + ((not (pair? vars)) + (hashq-set! allocation vars + (make-hashq proc + `(#t ,(hashq-ref assigned vars) . ,n))) + ;; the 1+ for this var + (max nmax (allocate! body proc (1+ n)))) + (else + (let ((v (car vars))) + (hashq-set! + allocation v + (make-hashq proc + `(#t ,(hashq-ref assigned v) . ,n))) + (lp (cdr vars) (1+ n)))))))) + + (else n))) + + (analyze! x #f '() #t #f) + (allocate! x #f 0) + + allocation) + + +;;; +;;; Unused variable analysis. +;;; + +;; <binding-info> records are used during tree traversals in +;; `report-unused-variables'. They contain a list of the local vars +;; currently in scope, a list of locals vars that have been referenced, and a +;; "location stack" (the stack of `tree-il-src' values for each parent tree). +(define-record-type <binding-info> + (make-binding-info vars refs locs) + binding-info? + (vars binding-info-vars) ;; ((GENSYM NAME LOCATION) ...) + (refs binding-info-refs) ;; (GENSYM ...) + (locs binding-info-locs)) ;; (LOCATION ...) + +(define (report-unused-variables tree) + "Report about unused variables in TREE. Return TREE." + + (define (dotless-list lst) + ;; If LST is a dotted list, return a proper list equal to LST except that + ;; the very last element is a pair; otherwise return LST. + (let loop ((lst lst) + (result '())) + (cond ((null? lst) + (reverse result)) + ((pair? lst) + (loop (cdr lst) (cons (car lst) result))) + (else + (loop '() (cons lst result)))))) + + (tree-il-fold (lambda (x info) + ;; X is a leaf: extend INFO's refs accordingly. + (let ((refs (binding-info-refs info)) + (vars (binding-info-vars info)) + (locs (binding-info-locs info))) + (record-case x + ((<lexical-ref> gensym) + (make-binding-info vars (cons gensym refs) locs)) + (else info)))) + + (lambda (x info) + ;; Going down into X: extend INFO's variable list + ;; accordingly. + (let ((refs (binding-info-refs info)) + (vars (binding-info-vars info)) + (locs (binding-info-locs info)) + (src (tree-il-src x))) + (define (extend inner-vars inner-names) + (append (map (lambda (var name) + (list var name src)) + inner-vars + inner-names) + vars)) + (record-case x + ((<lexical-set> gensym) + (make-binding-info vars (cons gensym refs) + (cons src locs))) + ((<lambda> vars names) + (let ((vars (dotless-list vars)) + (names (dotless-list names))) + (make-binding-info (extend vars names) refs + (cons src locs)))) + ((<let> vars names) + (make-binding-info (extend vars names) refs + (cons src locs))) + ((<letrec> vars names) + (make-binding-info (extend vars names) refs + (cons src locs))) + ((<fix> vars names) + (make-binding-info (extend vars names) refs + (cons src locs))) + ((<let-values> vars names) + (make-binding-info (extend vars names) refs + (cons src locs))) + (else info)))) + + (lambda (x info) + ;; Leaving X's scope: shrink INFO's variable list + ;; accordingly and reported unused nested variables. + (let ((refs (binding-info-refs info)) + (vars (binding-info-vars info)) + (locs (binding-info-locs info))) + (define (shrink inner-vars refs) + (for-each (lambda (var) + (let ((gensym (car var))) + ;; Don't report lambda parameters as + ;; unused. + (if (and (not (memq gensym refs)) + (not (and (lambda? x) + (memq gensym + inner-vars)))) + (let ((name (cadr var)) + ;; We can get approximate + ;; source location by going up + ;; the LOCS location stack. + (loc (or (caddr var) + (find pair? locs)))) + (warning 'unused-variable loc name))))) + (filter (lambda (var) + (memq (car var) inner-vars)) + vars)) + (fold alist-delete vars inner-vars)) + + ;; For simplicity, we leave REFS untouched, i.e., with + ;; names of variables that are now going out of scope. + ;; It doesn't hurt as these are unique names, it just + ;; makes REFS unnecessarily fat. + (record-case x + ((<lambda> vars) + (let ((vars (dotless-list vars))) + (make-binding-info (shrink vars refs) refs + (cdr locs)))) + ((<let> vars) + (make-binding-info (shrink vars refs) refs + (cdr locs))) + ((<letrec> vars) + (make-binding-info (shrink vars refs) refs + (cdr locs))) + ((<fix> vars) + (make-binding-info (shrink vars refs) refs + (cdr locs))) + ((<let-values> vars) + (make-binding-info (shrink vars refs) refs + (cdr locs))) + (else info)))) + (make-binding-info '() '() '()) + tree) + tree) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm new file mode 100644 index 000000000..86b610f94 --- /dev/null +++ b/module/language/tree-il/compile-glil.scm @@ -0,0 +1,729 @@ +;;; 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 compile-glil) + #:use-module (system base syntax) + #:use-module (system base pmatch) + #:use-module (system base message) + #:use-module (ice-9 receive) + #:use-module (language glil) + #:use-module (system vm instruction) + #:use-module (language tree-il) + #:use-module (language tree-il optimize) + #:use-module (language tree-il analyze) + #:export (compile-glil)) + +;;; TODO: +;; +;; call-with-values -> mv-bind +;; basic degenerate-case reduction + +;; allocation: +;; sym -> {lambda -> address} +;; lambda -> (nlocs labels . free-locs) +;; +;; address := (local? boxed? . index) +;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...) +;; free variable addresses are relative to parent proc. + +(define *comp-module* (make-fluid)) + +(define %warning-passes + `((unused-variable . ,report-unused-variables))) + +(define (compile-glil x e opts) + (define warnings + (or (and=> (memq #:warnings opts) cadr) + '())) + + ;; Go throught the warning passes. + (for-each (lambda (kind) + (let ((warn (assoc-ref %warning-passes kind))) + (and (procedure? warn) + (warn x)))) + warnings) + + (let* ((x (make-lambda (tree-il-src x) '() '() '() x)) + (x (optimize! x e opts)) + (allocation (analyze-lexicals x))) + + (with-fluid* *comp-module* (or (and e (car e)) (current-module)) + (lambda () + (values (flatten-lambda x #f allocation) + (and e (cons (car e) (cddr e))) + e))))) + + + +(define *primcall-ops* (make-hash-table)) +(for-each + (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x))) + '(((eq? . 2) . eq?) + ((eqv? . 2) . eqv?) + ((equal? . 2) . equal?) + ((= . 2) . ee?) + ((< . 2) . lt?) + ((> . 2) . gt?) + ((<= . 2) . le?) + ((>= . 2) . ge?) + ((+ . 2) . add) + ((- . 2) . sub) + ((1+ . 1) . add1) + ((1- . 1) . sub1) + ((* . 2) . mul) + ((/ . 2) . div) + ((quotient . 2) . quo) + ((remainder . 2) . rem) + ((modulo . 2) . mod) + ((not . 1) . not) + ((pair? . 1) . pair?) + ((cons . 2) . cons) + ((car . 1) . car) + ((cdr . 1) . cdr) + ((set-car! . 2) . set-car!) + ((set-cdr! . 2) . set-cdr!) + ((null? . 1) . null?) + ((list? . 1) . list?) + (list . list) + (vector . vector) + ((@slot-ref . 2) . slot-ref) + ((@slot-set! . 3) . slot-set) + ((vector-ref . 2) . vector-ref) + ((vector-set! . 3) . vector-set) + + ((bytevector-u8-ref . 2) . bv-u8-ref) + ((bytevector-u8-set! . 3) . bv-u8-set) + ((bytevector-s8-ref . 2) . bv-s8-ref) + ((bytevector-s8-set! . 3) . bv-s8-set) + + ((bytevector-u16-ref . 3) . bv-u16-ref) + ((bytevector-u16-set! . 4) . bv-u16-set) + ((bytevector-u16-native-ref . 2) . bv-u16-native-ref) + ((bytevector-u16-native-set! . 3) . bv-u16-native-set) + ((bytevector-s16-ref . 3) . bv-s16-ref) + ((bytevector-s16-set! . 4) . bv-s16-set) + ((bytevector-s16-native-ref . 2) . bv-s16-native-ref) + ((bytevector-s16-native-set! . 3) . bv-s16-native-set) + + ((bytevector-u32-ref . 3) . bv-u32-ref) + ((bytevector-u32-set! . 4) . bv-u32-set) + ((bytevector-u32-native-ref . 2) . bv-u32-native-ref) + ((bytevector-u32-native-set! . 3) . bv-u32-native-set) + ((bytevector-s32-ref . 3) . bv-s32-ref) + ((bytevector-s32-set! . 4) . bv-s32-set) + ((bytevector-s32-native-ref . 2) . bv-s32-native-ref) + ((bytevector-s32-native-set! . 3) . bv-s32-native-set) + + ((bytevector-u64-ref . 3) . bv-u64-ref) + ((bytevector-u64-set! . 4) . bv-u64-set) + ((bytevector-u64-native-ref . 2) . bv-u64-native-ref) + ((bytevector-u64-native-set! . 3) . bv-u64-native-set) + ((bytevector-s64-ref . 3) . bv-s64-ref) + ((bytevector-s64-set! . 4) . bv-s64-set) + ((bytevector-s64-native-ref . 2) . bv-s64-native-ref) + ((bytevector-s64-native-set! . 3) . bv-s64-native-set) + + ((bytevector-ieee-single-ref . 3) . bv-f32-ref) + ((bytevector-ieee-single-set! . 4) . bv-f32-set) + ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref) + ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set) + ((bytevector-ieee-double-ref . 3) . bv-f64-ref) + ((bytevector-ieee-double-set! . 4) . bv-f64-set) + ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref) + ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set))) + + + + +(define (make-label) (gensym ":L")) + +(define (vars->bind-list ids vars allocation proc) + (map (lambda (id v) + (pmatch (hashq-ref (hashq-ref allocation v) proc) + ((#t ,boxed? . ,n) + (list id boxed? n)) + (,x (error "badness" x)))) + ids + vars)) + +;; FIXME: always emit? otherwise it's hard to pair bind with unbind +(define (emit-bindings src ids vars allocation proc emit-code) + (emit-code src (make-glil-bind + (vars->bind-list ids vars allocation proc)))) + +(define (with-output-to-code proc) + (let ((out '())) + (define (emit-code src x) + (set! out (cons x out)) + (if src + (set! out (cons (make-glil-source src) out)))) + (proc emit-code) + (reverse out))) + +(define (flatten-lambda x self-label allocation) + (receive (ids vars nargs nrest) + (let lp ((ids (lambda-names x)) (vars (lambda-vars x)) + (oids '()) (ovars '()) (n 0)) + (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0)) + ((pair? vars) (lp (cdr ids) (cdr vars) + (cons (car ids) oids) (cons (car vars) ovars) + (1+ n))) + (else (values (reverse (cons ids oids)) + (reverse (cons vars ovars)) + (1+ n) 1)))) + (let ((nlocs (car (hashq-ref allocation x))) + (labels (cadr (hashq-ref allocation x)))) + (make-glil-program + nargs nrest nlocs (lambda-meta x) + (with-output-to-code + (lambda (emit-code) + ;; emit label for self tail calls + (if self-label + (emit-code #f (make-glil-label self-label))) + ;; write bindings and source debugging info + (if (not (null? ids)) + (emit-bindings #f ids vars allocation x emit-code)) + (if (lambda-src x) + (emit-code #f (make-glil-source (lambda-src x)))) + ;; 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) allocation x self-label + labels emit-code))))))) + +(define (flatten x allocation self self-label fix-labels emit-code) + (define (emit-label label) + (emit-code #f (make-glil-label label))) + (define (emit-branch src inst label) + (emit-code src (make-glil-branch inst label))) + + ;; RA: "return address"; #f unless we're in a non-tail fix with labels + ;; MVRA: "multiple-values return address"; #f unless we're in a let-values + (let comp ((x x) (context 'tail) (RA #f) (MVRA #f)) + (define (comp-tail tree) (comp tree context RA MVRA)) + (define (comp-push tree) (comp tree 'push #f #f)) + (define (comp-drop tree) (comp tree 'drop #f #f)) + (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA)) + (define (comp-fix tree RA) (comp tree context RA MVRA)) + + ;; A couple of helpers. Note that if we are in tail context, we + ;; won't have an RA. + (define (maybe-emit-return) + (if RA + (emit-branch #f 'br RA) + (if (eq? context 'tail) + (emit-code #f (make-glil-call 'return 1))))) + + (record-case x + ((<void>) + (case context + ((push vals tail) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) + + ((<const> src exp) + (case context + ((push vals tail) + (emit-code src (make-glil-const exp)))) + (maybe-emit-return)) + + ;; FIXME: should represent sequence as exps tail + ((<sequence> src exps) + (let lp ((exps exps)) + (if (null? (cdr exps)) + (comp-tail (car exps)) + (begin + (comp-drop (car exps)) + (lp (cdr exps)))))) + + ((<application> src proc args) + ;; FIXME: need a better pattern-matcher here + (cond + ((and (primitive-ref? proc) + (eq? (primitive-ref-name proc) '@apply) + (>= (length args) 1)) + (let ((proc (car args)) + (args (cdr args))) + (cond + ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) + (not (eq? context 'push)) (not (eq? context 'vals))) + ;; tail: (lambda () (apply values '(1 2))) + ;; drop: (lambda () (apply values '(1 2)) 3) + ;; push: (lambda () (list (apply values '(10 12)) 1)) + (case context + ((drop) (for-each comp-drop args) (maybe-emit-return)) + ((tail) + (for-each comp-push args) + (emit-code src (make-glil-call 'return/values* (length args)))))) + + (else + (case context + ((tail) + (comp-push proc) + (for-each comp-push args) + (emit-code src (make-glil-call 'goto/apply (1+ (length args))))) + ((push) + (emit-code src (make-glil-call 'new-frame 0)) + (comp-push proc) + (for-each comp-push args) + (emit-code src (make-glil-call 'apply (1+ (length args)))) + (maybe-emit-return)) + ((vals) + (comp-vals + (make-application src (make-primitive-ref #f 'apply) + (cons proc args)) + MVRA) + (maybe-emit-return)) + ((drop) + ;; Well, shit. The proc might return any number of + ;; values (including 0), since it's in a drop context, + ;; yet apply does not create a MV continuation. So we + ;; mv-call out to our trampoline instead. + (comp-drop + (make-application src (make-primitive-ref #f 'apply) + (cons proc args))) + (maybe-emit-return))))))) + + ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) + (not (eq? context 'push))) + ;; tail: (lambda () (values '(1 2))) + ;; drop: (lambda () (values '(1 2)) 3) + ;; push: (lambda () (list (values '(10 12)) 1)) + ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...) + (case context + ((drop) (for-each comp-drop args) (maybe-emit-return)) + ((vals) + (for-each comp-push args) + (emit-code #f (make-glil-const (length args))) + (emit-branch src 'br MVRA)) + ((tail) + (for-each comp-push args) + (emit-code src (make-glil-call 'return/values (length args)))))) + + ((and (primitive-ref? proc) + (eq? (primitive-ref-name proc) '@call-with-values) + (= (length args) 2)) + ;; CONSUMER + ;; PRODUCER + ;; (mv-call MV) + ;; ([tail]-call 1) + ;; goto POST + ;; MV: [tail-]call/nargs + ;; POST: (maybe-drop) + (case context + ((vals) + ;; Fall back. + (comp-vals + (make-application src (make-primitive-ref #f 'call-with-values) + args) + MVRA) + (maybe-emit-return)) + (else + (let ((MV (make-label)) (POST (make-label)) + (producer (car args)) (consumer (cadr args))) + (if (not (eq? context 'tail)) + (emit-code src (make-glil-call 'new-frame 0))) + (comp-push consumer) + (emit-code src (make-glil-call 'new-frame 0)) + (comp-push producer) + (emit-code src (make-glil-mv-call 0 MV)) + (case context + ((tail) (emit-code src (make-glil-call 'goto/args 1))) + (else (emit-code src (make-glil-call 'call 1)) + (emit-branch #f 'br POST))) + (emit-label MV) + (case context + ((tail) (emit-code src (make-glil-call 'goto/nargs 0))) + (else (emit-code src (make-glil-call 'call/nargs 0)) + (emit-label POST) + (if (eq? context 'drop) + (emit-code #f (make-glil-call 'drop 1))) + (maybe-emit-return))))))) + + ((and (primitive-ref? proc) + (eq? (primitive-ref-name proc) '@call-with-current-continuation) + (= (length args) 1)) + (case context + ((tail) + (comp-push (car args)) + (emit-code src (make-glil-call 'goto/cc 1))) + ((vals) + (comp-vals + (make-application + src (make-primitive-ref #f 'call-with-current-continuation) + args) + MVRA) + (maybe-emit-return)) + ((push) + (comp-push (car args)) + (emit-code src (make-glil-call 'call/cc 1)) + (maybe-emit-return)) + ((drop) + ;; Crap. Just like `apply' in drop context. + (comp-drop + (make-application + src (make-primitive-ref #f 'call-with-current-continuation) + args)) + (maybe-emit-return)))) + + ((and (primitive-ref? proc) + (or (hash-ref *primcall-ops* + (cons (primitive-ref-name proc) (length args))) + (hash-ref *primcall-ops* (primitive-ref-name proc)))) + => (lambda (op) + (for-each comp-push args) + (emit-code src (make-glil-call op (length args))) + (case (instruction-pushes op) + ((0) + (case context + ((tail push vals) (emit-code #f (make-glil-void)))) + (maybe-emit-return)) + ((1) + (case context + ((drop) (emit-code #f (make-glil-call 'drop 1)))) + (maybe-emit-return)) + (else + (error "bad primitive op: too many pushes" + op (instruction-pushes op)))))) + + ;; da capo al fine + ((and (lexical-ref? proc) + self-label (eq? (lexical-ref-gensym proc) self-label) + ;; self-call in tail position is a goto + (eq? context 'tail) + ;; make sure the arity is right + (list? (lambda-vars self)) + (= (length args) (length (lambda-vars self)))) + ;; evaluate new values + (for-each comp-push args) + ;; rename & goto + (for-each (lambda (sym) + (pmatch (hashq-ref (hashq-ref allocation sym) self) + ((#t ,boxed? . ,index) + ;; set unboxed, as the proc prelude will box if needed + (emit-code #f (make-glil-lexical #t #f 'set index))) + (,x (error "what" x)))) + (reverse (lambda-vars self))) + (emit-branch src 'br self-label)) + + ;; lambda, the ultimate goto + ((and (lexical-ref? proc) + (assq (lexical-ref-gensym proc) fix-labels)) + ;; evaluate new values, assuming that analyze-lexicals did its + ;; job, and that the arity was right + (for-each comp-push args) + ;; rename + (for-each (lambda (sym) + (pmatch (hashq-ref (hashq-ref allocation sym) self) + ((#t #f . ,index) + (emit-code #f (make-glil-lexical #t #f 'set index))) + ((#t #t . ,index) + (emit-code #f (make-glil-lexical #t #t 'box index))) + (,x (error "what" x)))) + (reverse (assq-ref fix-labels (lexical-ref-gensym proc)))) + ;; goto! + (emit-branch src 'br (lexical-ref-gensym proc))) + + (else + (if (not (eq? context 'tail)) + (emit-code src (make-glil-call 'new-frame 0))) + (comp-push proc) + (for-each comp-push args) + (let ((len (length args))) + (case context + ((tail) (emit-code src (make-glil-call 'goto/args len))) + ((push) (emit-code src (make-glil-call 'call len)) + (maybe-emit-return)) + ((vals) (emit-code src (make-glil-mv-call len MVRA)) + (maybe-emit-return)) + ((drop) (let ((MV (make-label)) (POST (make-label))) + (emit-code src (make-glil-mv-call len MV)) + (emit-code #f (make-glil-call 'drop 1)) + (emit-branch #f 'br (or RA POST)) + (emit-label MV) + (emit-code #f (make-glil-mv-bind '() #f)) + (emit-code #f (make-glil-unbind)) + (if RA + (emit-branch #f 'br RA) + (emit-label POST))))))))) + + ((<conditional> src test then else) + ;; TEST + ;; (br-if-not L1) + ;; THEN + ;; (br L2) + ;; L1: ELSE + ;; L2: + (let ((L1 (make-label)) (L2 (make-label))) + (comp-push test) + (emit-branch src 'br-if-not L1) + (comp-tail then) + ;; if there is an RA, comp-tail will cause a jump to it -- just + ;; have to clean up here if there is no RA. + (if (and (not RA) (not (eq? context 'tail))) + (emit-branch #f 'br L2)) + (emit-label L1) + (comp-tail else) + (if (and (not RA) (not (eq? context 'tail))) + (emit-label L2)))) + + ((<primitive-ref> src name) + (cond + ((eq? (module-variable (fluid-ref *comp-module*) name) + (module-variable the-root-module name)) + (case context + ((tail push vals) + (emit-code src (make-glil-toplevel 'ref name)))) + (maybe-emit-return)) + ((module-variable the-root-module name) + (case context + ((tail push vals) + (emit-code src (make-glil-module 'ref '(guile) name #f)))) + (maybe-emit-return)) + (else + (case context + ((tail push vals) + (emit-code src (make-glil-module + 'ref (module-name (fluid-ref *comp-module*)) name #f)))) + (maybe-emit-return)))) + + ((<lexical-ref> src name gensym) + (case context + ((push vals tail) + (pmatch (hashq-ref (hashq-ref allocation gensym) self) + ((,local? ,boxed? . ,index) + (emit-code src (make-glil-lexical local? boxed? 'ref index))) + (,loc + (error "badness" x loc))))) + (maybe-emit-return)) + + ((<lexical-set> src name gensym exp) + (comp-push exp) + (pmatch (hashq-ref (hashq-ref allocation gensym) self) + ((,local? ,boxed? . ,index) + (emit-code src (make-glil-lexical local? boxed? 'set index))) + (,loc + (error "badness" x loc))) + (case context + ((tail push vals) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) + + ((<module-ref> src mod name public?) + (emit-code src (make-glil-module 'ref mod name public?)) + (case context + ((drop) (emit-code #f (make-glil-call 'drop 1)))) + (maybe-emit-return)) + + ((<module-set> src mod name public? exp) + (comp-push exp) + (emit-code src (make-glil-module 'set mod name public?)) + (case context + ((tail push vals) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) + + ((<toplevel-ref> src name) + (emit-code src (make-glil-toplevel 'ref name)) + (case context + ((drop) (emit-code #f (make-glil-call 'drop 1)))) + (maybe-emit-return)) + + ((<toplevel-set> src name exp) + (comp-push exp) + (emit-code src (make-glil-toplevel 'set name)) + (case context + ((tail push vals) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) + + ((<toplevel-define> src name exp) + (comp-push exp) + (emit-code src (make-glil-toplevel 'define name)) + (case context + ((tail push vals) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) + + ((<lambda>) + (let ((free-locs (cddr (hashq-ref allocation x)))) + (case context + ((push vals tail) + (emit-code #f (flatten-lambda x #f allocation)) + (if (not (null? free-locs)) + (begin + (for-each + (lambda (loc) + (pmatch loc + ((,local? ,boxed? . ,n) + (emit-code #f (make-glil-lexical local? #f 'ref n))) + (else (error "what" x loc)))) + free-locs) + (emit-code #f (make-glil-call 'vector (length free-locs))) + (emit-code #f (make-glil-call 'make-closure 2))))))) + (maybe-emit-return)) + + ((<let> src names vars vals body) + (for-each comp-push vals) + (emit-bindings src names vars allocation self emit-code) + (for-each (lambda (v) + (pmatch (hashq-ref (hashq-ref allocation v) self) + ((#t #f . ,n) + (emit-code src (make-glil-lexical #t #f 'set n))) + ((#t #t . ,n) + (emit-code src (make-glil-lexical #t #t 'box n))) + (,loc (error "badness" x loc)))) + (reverse vars)) + (comp-tail body) + (emit-code #f (make-glil-unbind))) + + ((<letrec> src names vars vals body) + (for-each (lambda (v) + (pmatch (hashq-ref (hashq-ref allocation v) self) + ((#t #t . ,n) + (emit-code src (make-glil-lexical #t #t 'empty-box n))) + (,loc (error "badness" x loc)))) + vars) + (for-each comp-push vals) + (emit-bindings src names vars allocation self emit-code) + (for-each (lambda (v) + (pmatch (hashq-ref (hashq-ref allocation v) self) + ((#t #t . ,n) + (emit-code src (make-glil-lexical #t #t 'set n))) + (,loc (error "badness" x loc)))) + (reverse vars)) + (comp-tail body) + (emit-code #f (make-glil-unbind))) + + ((<fix> src names vars vals body) + ;; The ideal here is to just render the lambda bodies inline, and + ;; wire the code together with gotos. We can do that if + ;; analyze-lexicals has determined that a given var has "label" + ;; allocation -- which is the case if it is in `fix-labels'. + ;; + ;; But even for closures that we can't inline, we can do some + ;; tricks to avoid heap-allocation for the binding itself. Since + ;; we know the vals are lambdas, we can set them to their local + ;; var slots first, then capture their bindings, mutating them in + ;; place. + (let ((RA (if (eq? context 'tail) #f (make-label)))) + (for-each + (lambda (x v) + (cond + ((hashq-ref allocation x) + ;; allocating a closure + (emit-code #f (flatten-lambda x v allocation)) + (if (not (null? (cddr (hashq-ref allocation x)))) + ;; Need to make-closure first, but with a temporary #f + ;; free-variables vector, so we are mutating fresh + ;; closures on the heap. + (begin + (emit-code #f (make-glil-const #f)) + (emit-code #f (make-glil-call 'make-closure 2)))) + (pmatch (hashq-ref (hashq-ref allocation v) self) + ((#t #f . ,n) + (emit-code src (make-glil-lexical #t #f 'set n))) + (,loc (error "badness" x loc)))) + (else + ;; labels allocation: emit label & body, but jump over it + (let ((POST (make-label))) + (emit-branch #f 'br POST) + (emit-label v) + ;; we know the lambda vars are a list + (emit-bindings #f (lambda-names x) (lambda-vars x) + allocation self emit-code) + (if (lambda-src x) + (emit-code #f (make-glil-source (lambda-src x)))) + (comp-fix (lambda-body x) RA) + (emit-code #f (make-glil-unbind)) + (emit-label POST))))) + vals + vars) + ;; Emit bindings metadata for closures + (let ((binds (let lp ((out '()) (vars vars) (names names)) + (cond ((null? vars) (reverse! out)) + ((assq (car vars) fix-labels) + (lp out (cdr vars) (cdr names))) + (else + (lp (acons (car vars) (car names) out) + (cdr vars) (cdr names))))))) + (emit-bindings src (map cdr binds) (map car binds) + allocation self emit-code)) + ;; Now go back and fix up the bindings for closures. + (for-each + (lambda (x v) + (let ((free-locs (if (hashq-ref allocation x) + (cddr (hashq-ref allocation x)) + ;; can hit this latter case for labels 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))) + (pmatch (hashq-ref (hashq-ref allocation v) self) + ((#t #f . ,n) + (emit-code #f (make-glil-lexical #t #f 'fix n))) + (,loc (error "badness" x loc))))))) + vals + vars) + (comp-tail body) + (emit-label RA) + (emit-code #f (make-glil-unbind)))) + + ((<let-values> src names vars exp body) + (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f)) + (cond + ((pair? inames) + (lp (cons (car inames) names) (cons (car ivars) vars) + (cdr inames) (cdr ivars) #f)) + ((not (null? inames)) + (lp (cons inames names) (cons ivars vars) '() '() #t)) + (else + (let ((names (reverse! names)) + (vars (reverse! vars)) + (MV (make-label))) + (comp-vals exp MV) + (emit-code #f (make-glil-const 1)) + (emit-label MV) + (emit-code src (make-glil-mv-bind + (vars->bind-list names vars allocation self) + rest?)) + (for-each (lambda (v) + (pmatch (hashq-ref (hashq-ref allocation v) self) + ((#t #f . ,n) + (emit-code src (make-glil-lexical #t #f 'set n))) + ((#t #t . ,n) + (emit-code src (make-glil-lexical #t #t 'box n))) + (,loc (error "badness" x loc)))) + (reverse vars)) + (comp-tail body) + (emit-code #f (make-glil-unbind)))))))))) diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm new file mode 100644 index 000000000..9b66d9ed5 --- /dev/null +++ b/module/language/tree-il/fix-letrec.scm @@ -0,0 +1,240 @@ +;;; transformation of letrec into simpler forms + +;; Copyright (C) 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 + +(define-module (language tree-il fix-letrec) + #:use-module (system base syntax) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (language tree-il) + #:use-module (language tree-il primitives) + #:export (fix-letrec!)) + +;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet +;; Efficient Implementation of Scheme’s Recursive Binding Construct", by +;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig. + +(define fix-fold + (make-tree-il-folder unref ref set simple lambda complex)) + +(define (simple-expression? x bound-vars) + (record-case x + ((<void>) #t) + ((<const>) #t) + ((<lexical-ref> gensym) + (not (memq gensym bound-vars))) + ((<conditional> test then else) + (and (simple-expression? test bound-vars) + (simple-expression? then bound-vars) + (simple-expression? else bound-vars))) + ((<sequence> exps) + (and-map (lambda (x) (simple-expression? x bound-vars)) + exps)) + ((<application> proc args) + (and (primitive-ref? proc) + (effect-free-primitive? (primitive-ref-name proc)) + (and-map (lambda (x) (simple-expression? x bound-vars)) + args))) + (else #f))) + +(define (partition-vars x) + (let-values + (((unref ref set simple lambda* complex) + (fix-fold x + (lambda (x unref ref set simple lambda* complex) + (record-case x + ((<lexical-ref> gensym) + (values (delq gensym unref) + (lset-adjoin eq? ref gensym) + set + simple + lambda* + complex)) + ((<lexical-set> gensym) + (values unref + ref + (lset-adjoin eq? set gensym) + simple + lambda* + complex)) + ((<letrec> vars) + (values (append vars unref) + ref + set + simple + lambda* + complex)) + ((<let> vars) + (values (append vars unref) + ref + set + simple + lambda* + complex)) + (else + (values unref ref set simple lambda* complex)))) + (lambda (x unref ref set simple lambda* complex) + (record-case x + ((<letrec> (orig-vars vars) vals) + (let lp ((vars orig-vars) (vals vals) + (s '()) (l '()) (c '())) + (cond + ((null? vars) + (values unref + ref + set + (append s simple) + (append l lambda*) + (append c complex))) + ((memq (car vars) unref) + (lp (cdr vars) (cdr vals) + s l c)) + ((memq (car vars) set) + (lp (cdr vars) (cdr vals) + s l (cons (car vars) c))) + ((lambda? (car vals)) + (lp (cdr vars) (cdr vals) + s (cons (car vars) l) c)) + ((simple-expression? (car vals) orig-vars) + (lp (cdr vars) (cdr vals) + (cons (car vars) s) l c)) + (else + (lp (cdr vars) (cdr vals) + s l (cons (car vars) c)))))) + ((<let> (orig-vars vars) vals) + ;; The point is to compile let-bound lambdas as + ;; efficiently as we do letrec-bound lambdas, so + ;; we use the same algorithm for analyzing the + ;; vars. There is no problem recursing into the + ;; bindings after the let, because all variables + ;; have been renamed. + (let lp ((vars orig-vars) (vals vals) + (s '()) (l '()) (c '())) + (cond + ((null? vars) + (values unref + ref + set + (append s simple) + (append l lambda*) + (append c complex))) + ((memq (car vars) unref) + (lp (cdr vars) (cdr vals) + s l c)) + ((memq (car vars) set) + (lp (cdr vars) (cdr vals) + s l (cons (car vars) c))) + ((and (lambda? (car vals)) + (not (memq (car vars) set))) + (lp (cdr vars) (cdr vals) + s (cons (car vars) l) c)) + ;; There is no difference between simple and + ;; complex, for the purposes of let. Just lump + ;; them all into complex. + (else + (lp (cdr vars) (cdr vals) + s l (cons (car vars) c)))))) + (else + (values unref ref set simple lambda* complex)))) + '() + '() + '() + '() + '() + '()))) + (values unref simple lambda* complex))) + +(define (fix-letrec! x) + (let-values (((unref simple lambda* complex) (partition-vars x))) + (post-order! + (lambda (x) + (record-case x + + ;; Sets to unreferenced variables may be replaced by their + ;; expression, called for effect. + ((<lexical-set> gensym exp) + (if (memq gensym unref) + (make-sequence #f (list exp (make-void #f))) + x)) + + ((<letrec> src names vars vals body) + (let ((binds (map list vars names vals))) + (define (lookup set) + (map (lambda (v) (assq v binds)) + (lset-intersection eq? vars set))) + (let ((u (lookup unref)) + (s (lookup simple)) + (l (lookup lambda*)) + (c (lookup complex))) + ;; Bind "simple" bindings, and locations for complex + ;; bindings. + (make-let + src + (append (map cadr s) (map cadr c)) + (append (map car s) (map car c)) + (append (map caddr s) (map (lambda (x) (make-void #f)) c)) + ;; Bind lambdas using the fixpoint operator. + (make-fix + src (map cadr l) (map car l) (map caddr l) + (make-sequence + src + (append + ;; The right-hand-sides of the unreferenced + ;; bindings, for effect. + (map caddr u) + (if (null? c) + ;; No complex bindings, just emit the body. + (list body) + (list + ;; Evaluate the the "complex" bindings, in a `let' to + ;; indicate that order doesn't matter, and bind to + ;; their variables. + (let ((tmps (map (lambda (x) (gensym)) c))) + (make-let + #f (map cadr c) tmps (map caddr c) + (make-sequence + #f + (map (lambda (x tmp) + (make-lexical-set + #f (cadr x) (car x) + (make-lexical-ref #f (cadr x) tmp))) + c tmps)))) + ;; Finally, the body. + body))))))))) + + ((<let> src names vars vals body) + (let ((binds (map list vars names vals))) + (define (lookup set) + (map (lambda (v) (assq v binds)) + (lset-intersection eq? vars set))) + (let ((u (lookup unref)) + (l (lookup lambda*)) + (c (lookup complex))) + (make-sequence + src + (append + ;; unreferenced bindings, called for effect. + (map caddr u) + (list + ;; unassigned lambdas use fix. + (make-fix src (map cadr l) (map car l) (map caddr l) + ;; and the "complex" bindings. + (make-let src (map cadr c) (map car c) (map caddr c) + body)))))))) + + (else x))) + x))) diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm new file mode 100644 index 000000000..adc3f18bd --- /dev/null +++ b/module/language/tree-il/inline.scm @@ -0,0 +1,81 @@ +;;; a simple inliner + +;; Copyright (C) 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 + +(define-module (language tree-il inline) + #:use-module (system base syntax) + #:use-module (language tree-il) + #:export (inline!)) + +;; Possible optimizations: +;; * constant folding, propagation +;; * procedure inlining +;; * always when single call site +;; * always for "trivial" procs +;; * otherwise who knows +;; * dead code elimination +;; * degenerate case optimizations +;; * "fixing letrec" + +;; This is a completely brain-dead optimization pass whose sole claim to +;; fame is ((lambda () x)) => x. +(define (inline! x) + (post-order! + (lambda (x) + (record-case x + ((<application> src proc args) + (cond + + ;; ((lambda () x)) => x + ((and (lambda? proc) (null? (lambda-vars proc)) + (null? args)) + (lambda-body proc)) + + ;; (call-with-values (lambda () foo) (lambda (a b . c) bar)) + ;; => (let-values (((a b . c) foo)) bar) + ;; + ;; Note that this is a singly-binding form of let-values. Also + ;; note that Scheme's let-values expands into call-with-values, + ;; then here we reduce it to tree-il's let-values. + ((and (primitive-ref? proc) + (eq? (primitive-ref-name proc) '@call-with-values) + (= (length args) 2) + (lambda? (cadr args))) + (let ((producer (car args)) + (consumer (cadr args))) + (make-let-values src + (lambda-names consumer) + (lambda-vars consumer) + (if (and (lambda? producer) + (null? (lambda-names producer))) + (lambda-body producer) + (make-application src producer '())) + (lambda-body consumer)))) + + (else #f))) + + ((<let> vars body) + (if (null? vars) body x)) + + ((<letrec> vars body) + (if (null? vars) body x)) + + ((<fix> vars body) + (if (null? vars) body x)) + + (else #f))) + x)) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm new file mode 100644 index 000000000..0e490a636 --- /dev/null +++ b/module/language/tree-il/optimize.scm @@ -0,0 +1,35 @@ +;;; Tree-il optimizer + +;; Copyright (C) 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 optimize) + #:use-module (language tree-il) + #:use-module (language tree-il primitives) + #:use-module (language tree-il inline) + #:use-module (language tree-il fix-letrec) + #:export (optimize!)) + +(define (env-module e) + (if e (car e) (current-module))) + +(define (optimize! x env opts) + (inline! + (fix-letrec! + (expand-primitives! + (resolve-primitives! x (env-module env)))))) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm new file mode 100644 index 000000000..955c7bf25 --- /dev/null +++ b/module/language/tree-il/primitives.scm @@ -0,0 +1,287 @@ +;;; open-coding primitive procedures + +;; Copyright (C) 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 primitives) + #:use-module (system base pmatch) + #:use-module (rnrs bytevector) + #:use-module (system base syntax) + #:use-module (language tree-il) + #:use-module (srfi srfi-16) + #:export (resolve-primitives! add-interesting-primitive! + expand-primitives! effect-free-primitive?)) + +(define *interesting-primitive-names* + '(apply @apply + call-with-values @call-with-values + call-with-current-continuation @call-with-current-continuation + call/cc + values + eq? eqv? equal? + = < > <= >= zero? + + * - / 1- 1+ quotient remainder modulo + not + pair? null? list? acons cons cons* + + list vector + + car cdr + set-car! set-cdr! + + caar cadr cdar cddr + + caaar caadr cadar caddr cdaar cdadr cddar cdddr + + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + + vector-ref vector-set! + + bytevector-u8-ref bytevector-u8-set! + bytevector-s8-ref bytevector-s8-set! + + bytevector-u16-ref bytevector-u16-set! + bytevector-u16-native-ref bytevector-u16-native-set! + bytevector-s16-ref bytevector-s16-set! + bytevector-s16-native-ref bytevector-s16-native-set! + + bytevector-u32-ref bytevector-u32-set! + bytevector-u32-native-ref bytevector-u32-native-set! + bytevector-s32-ref bytevector-s32-set! + bytevector-s32-native-ref bytevector-s32-native-set! + + bytevector-u64-ref bytevector-u64-set! + bytevector-u64-native-ref bytevector-u64-native-set! + bytevector-s64-ref bytevector-s64-set! + bytevector-s64-native-ref bytevector-s64-native-set! + + bytevector-ieee-single-ref bytevector-ieee-single-set! + bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! + bytevector-ieee-double-ref bytevector-ieee-double-set! + bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!)) + +(define (add-interesting-primitive! name) + (hashq-set! *interesting-primitive-vars* + (module-variable (current-module) name) + name)) + +(define *interesting-primitive-vars* (make-hash-table)) + +(for-each add-interesting-primitive! *interesting-primitive-names*) + +(define *effect-free-primitives* + '(values + eq? eqv? equal? + = < > <= >= zero? + + * - / 1- 1+ quotient remainder modulo + not + pair? null? list? acons cons cons* + list vector + car cdr + caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + vector-ref + bytevector-u8-ref bytevector-s8-ref + bytevector-u16-ref bytevector-u16-native-ref + bytevector-s16-ref bytevector-s16-native-ref + bytevector-u32-ref bytevector-u32-native-ref + bytevector-s32-ref bytevector-s32-native-ref + bytevector-u64-ref bytevector-u64-native-ref + bytevector-s64-ref bytevector-s64-native-ref + bytevector-ieee-single-ref bytevector-ieee-single-native-ref + bytevector-ieee-double-ref bytevector-ieee-double-native-ref)) + + +(define *effect-free-primitive-table* (make-hash-table)) + +(for-each (lambda (x) (hashq-set! *effect-free-primitive-table* x #t)) + *effect-free-primitives*) + +(define (effect-free-primitive? prim) + (hashq-ref *effect-free-primitive-table* prim)) + +(define (resolve-primitives! x mod) + (post-order! + (lambda (x) + (record-case x + ((<toplevel-ref> src name) + (and=> (hashq-ref *interesting-primitive-vars* + (module-variable mod name)) + (lambda (name) (make-primitive-ref src name)))) + ((<module-ref> src mod name public?) + ;; for the moment, we're disabling primitive resolution for + ;; public refs because resolve-interface can raise errors. + (let ((m (and (not public?) (resolve-module mod)))) + (and m + (and=> (hashq-ref *interesting-primitive-vars* + (module-variable m name)) + (lambda (name) (make-primitive-ref src name)))))) + (else #f))) + x)) + + + +(define *primitive-expand-table* (make-hash-table)) + +(define (expand-primitives! x) + (pre-order! + (lambda (x) + (record-case x + ((<application> src proc args) + (and (primitive-ref? proc) + (let ((expand (hashq-ref *primitive-expand-table* + (primitive-ref-name proc)))) + (and expand (apply expand src args))))) + (else #f))) + x)) + +;;; I actually did spend about 10 minutes trying to redo this with +;;; syntax-rules. Patches appreciated. +;;; +(define-macro (define-primitive-expander sym . clauses) + (define (inline-args args) + (let lp ((in args) (out '())) + (cond ((null? in) `(list ,@(reverse out))) + ((symbol? in) `(cons* ,@(reverse out) ,in)) + ((pair? (car in)) + (lp (cdr in) + (cons `(make-application src (make-primitive-ref src ',(caar in)) + ,(inline-args (cdar in))) + out))) + ((symbol? (car in)) + ;; assume it's locally bound + (lp (cdr in) (cons (car in) out))) + ((number? (car in)) + (lp (cdr in) (cons `(make-const src ,(car in)) out))) + (else + (error "what what" (car in)))))) + (define (consequent exp) + (cond + ((pair? exp) + (pmatch exp + ((if ,test ,then ,else) + `(if ,test + ,(consequent then) + ,(consequent else))) + (else + `(make-application src (make-primitive-ref src ',(car exp)) + ,(inline-args (cdr exp)))))) + ((symbol? exp) + ;; assume locally bound + exp) + ((number? exp) + `(make-const src ,exp)) + (else (error "bad consequent yall" exp)))) + `(hashq-set! *primitive-expand-table* + ',sym + (case-lambda + ,@(let lp ((in clauses) (out '())) + (if (null? in) + (reverse (cons '(else #f) out)) + (lp (cddr in) + (cons `((src . ,(car in)) + ,(consequent (cadr in))) out))))))) + +(define-primitive-expander zero? (x) + (= x 0)) + +(define-primitive-expander + + () 0 + (x) x + (x y) (if (and (const? y) + (let ((y (const-exp y))) + (and (exact? y) (= y 1)))) + (1+ x) + (if (and (const? x) + (let ((x (const-exp x))) + (and (exact? x) (= x 1)))) + (1+ y) + (+ x y))) + (x y z . rest) (+ x (+ y z . rest))) + +(define-primitive-expander * + () 1 + (x) x + (x y z . rest) (* x (* y z . rest))) + +(define-primitive-expander - + (x) (- 0 x) + (x y) (if (and (const? y) + (let ((y (const-exp y))) + (and (exact? y) (= y 1)))) + (1- x) + (- x y)) + (x y z . rest) (- x (+ y z . rest))) + +(define-primitive-expander / + (x) (/ 1 x) + (x y z . rest) (/ x (* y z . rest))) + +(define-primitive-expander caar (x) (car (car x))) +(define-primitive-expander cadr (x) (car (cdr x))) +(define-primitive-expander cdar (x) (cdr (car x))) +(define-primitive-expander cddr (x) (cdr (cdr x))) +(define-primitive-expander caaar (x) (car (car (car x)))) +(define-primitive-expander caadr (x) (car (car (cdr x)))) +(define-primitive-expander cadar (x) (car (cdr (car x)))) +(define-primitive-expander caddr (x) (car (cdr (cdr x)))) +(define-primitive-expander cdaar (x) (cdr (car (car x)))) +(define-primitive-expander cdadr (x) (cdr (car (cdr x)))) +(define-primitive-expander cddar (x) (cdr (cdr (car x)))) +(define-primitive-expander cdddr (x) (cdr (cdr (cdr x)))) +(define-primitive-expander caaaar (x) (car (car (car (car x))))) +(define-primitive-expander caaadr (x) (car (car (car (cdr x))))) +(define-primitive-expander caadar (x) (car (car (cdr (car x))))) +(define-primitive-expander caaddr (x) (car (car (cdr (cdr x))))) +(define-primitive-expander cadaar (x) (car (cdr (car (car x))))) +(define-primitive-expander cadadr (x) (car (cdr (car (cdr x))))) +(define-primitive-expander caddar (x) (car (cdr (cdr (car x))))) +(define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x))))) +(define-primitive-expander cdaaar (x) (cdr (car (car (car x))))) +(define-primitive-expander cdaadr (x) (cdr (car (car (cdr x))))) +(define-primitive-expander cdadar (x) (cdr (car (cdr (car x))))) +(define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x))))) +(define-primitive-expander cddaar (x) (cdr (cdr (car (car x))))) +(define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x))))) +(define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x))))) +(define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x))))) + +(define-primitive-expander cons* + (x) x + (x y) (cons x y) + (x y . rest) (cons x (cons* y . rest))) + +(define-primitive-expander acons (x y z) + (cons (cons x y) z)) + +(define-primitive-expander apply (f . args) + (@apply f . args)) + +(define-primitive-expander call-with-values (producer consumer) + (@call-with-values producer consumer)) + +(define-primitive-expander call-with-current-continuation (proc) + (@call-with-current-continuation proc)) + +(define-primitive-expander call/cc (proc) + (@call-with-current-continuation proc)) + +(define-primitive-expander values (x) x) diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm new file mode 100644 index 000000000..2d24f7bf6 --- /dev/null +++ b/module/language/tree-il/spec.scm @@ -0,0 +1,42 @@ +;;; Tree Intermediate Language + +;; Copyright (C) 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 spec) + #:use-module (system base language) + #:use-module (language glil) + #:use-module (language tree-il) + #:use-module (language tree-il compile-glil) + #:export (tree-il)) + +(define (write-tree-il exp . port) + (apply write (unparse-tree-il exp) port)) + +(define (join exps env) + (make-sequence #f exps)) + +(define-language tree-il + #:title "Tree Intermediate Language" + #:version "1.0" + #:reader read + #:printer write-tree-il + #:parser parse-tree-il + #:joiner join + #:compilers `((glil . ,compile-glil)) + ) |