diff options
-rw-r--r-- | module/Makefile.am | 2 | ||||
-rw-r--r-- | module/language/cps/spec.scm | 36 | ||||
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 594 | ||||
-rw-r--r-- | module/language/tree-il/spec.scm | 4 |
4 files changed, 635 insertions, 1 deletions
diff --git a/module/Makefile.am b/module/Makefile.am index 1f66ac4f8..fea910f5e 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -112,12 +112,14 @@ TREE_IL_LANG_SOURCES = \ language/tree-il/canonicalize.scm \ language/tree-il/analyze.scm \ language/tree-il/inline.scm \ + language/tree-il/compile-cps.scm \ language/tree-il/compile-glil.scm \ language/tree-il/debug.scm \ language/tree-il/spec.scm CPS_LANG_SOURCES = \ language/cps.scm \ + language/cps/spec.scm \ language/cps/verify.scm GLIL_LANG_SOURCES = \ diff --git a/module/language/cps/spec.scm b/module/language/cps/spec.scm new file mode 100644 index 000000000..38dc54d1c --- /dev/null +++ b/module/language/cps/spec.scm @@ -0,0 +1,36 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013 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 cps spec) + #:use-module (system base language) + #:use-module (language cps) + #:export (cps)) + +(define* (write-cps exp #:optional (port (current-output-port))) + (write (unparse-cps exp) port)) + +(define-language cps + #:title "CPS Intermediate Language" + #:reader (lambda (port env) (read port)) + #:printer write-cps + #:parser parse-cps + #:compilers '() + #:for-humans? #f + ) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm new file mode 100644 index 000000000..e7befbe41 --- /dev/null +++ b/module/language/tree-il/compile-cps.scm @@ -0,0 +1,594 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013 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 + +;;; Commentary: +;;; +;;; This pass converts Tree-IL to the continuation-passing style (CPS) +;;; language. +;;; +;;; CPS is a lower-level representation than Tree-IL. Converting to +;;; CPS, beyond adding names for all control points and all values, +;;; simplifies expressions in the following ways, among others: +;;; +;;; * Fixing the order of evaluation. +;;; +;;; * Converting assigned variables to boxed variables. +;;; +;;; * Requiring that Scheme's <letrec> has already been lowered to +;;; <fix>. +;;; +;;; * Inlining default-value initializers into lambda-case +;;; expressions. +;;; +;;; * Inlining prompt bodies. +;;; +;;; * Turning toplevel and module references into primcalls. This +;;; involves explicitly modelling the "scope" of toplevel lookups +;;; (indicating the module with respect to which toplevel bindings +;;; are resolved). +;;; +;;; The utility of CPS is that it gives a name to everything: every +;;; intermediate value, and every control point (continuation). As such +;;; it is more verbose than Tree-IL, but at the same time more simple as +;;; the number of concepts is reduced. +;;; +;;; Code: + +(define-module (language tree-il compile-cps) + #:use-module (ice-9 match) + #:use-module ((srfi srfi-1) #:select (fold fold-right filter-map)) + #:use-module (srfi srfi-26) + #:use-module ((system foreign) #:select (make-pointer pointer->scm)) + #:use-module (language cps) + #:use-module (language cps primitives) + #:use-module (language tree-il analyze) + #:use-module (language tree-il optimize) + #:use-module ((language tree-il) + #:select + (<void> + <const> <primitive-ref> <lexical-ref> <lexical-set> + <module-ref> <module-set> + <toplevel-ref> <toplevel-set> <toplevel-define> + <conditional> + <call> <primcall> + <seq> + <lambda> <lambda-case> + <let> <letrec> <fix> <let-values> + <prompt> <abort> + make-conditional make-const make-primcall + tree-il-src + tree-il-fold)) + #:export (compile-cps)) + +;;; Guile's semantics are that a toplevel lambda captures a reference on +;;; the current module, and that all contained lambdas use that module +;;; to resolve toplevel variables. This parameter tracks whether or not +;;; we are in a toplevel lambda. If we are in a lambda, the parameter +;;; is bound to a fresh name identifying the module that was current +;;; when the toplevel lambda is defined. +;;; +;;; This is more complicated than it need be. Ideally we should resolve +;;; all toplevel bindings to bindings from specific modules, unless the +;;; binding is unbound. This is always valid if the compilation unit +;;; sets the module explicitly, as when compiling a module, but it +;;; doesn't work for files auto-compiled for use with `load'. +;;; +(define current-topbox-scope (make-parameter #f)) + +(define (toplevel-box src name bound? val-proc) + (let-gensyms (name-sym bound?-sym kbox box) + (build-cps-term + ($letconst (('name name-sym name) + ('bound? bound?-sym bound?)) + ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box)))) + ,(match (current-topbox-scope) + (#f + (build-cps-term + ($continue kbox + ($primcall 'resolve + (name-sym bound?-sym))))) + (scope + (let-gensyms (scope-sym) + (build-cps-term + ($letconst (('scope scope-sym scope)) + ($continue kbox + ($primcall 'cached-toplevel-box + (scope-sym name-sym bound?-sym))))))))))))) + +(define (module-box src module name public? bound? val-proc) + (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box) + (build-cps-term + ($letconst (('module module-sym module) + ('name name-sym name) + ('public? public?-sym public?) + ('bound? bound?-sym bound?)) + ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box)))) + ($continue kbox + ($primcall 'cached-module-box + (module-sym name-sym public?-sym bound?-sym)))))))) + +(define (capture-toplevel-scope src scope k) + (let-gensyms (module scope-sym kmodule) + (build-cps-term + ($letconst (('scope scope-sym scope)) + ($letk ((kmodule src ($kargs ('module) (module) + ($continue k + ($primcall 'cache-current-module! + (module scope-sym)))))) + ($continue kmodule + ($primcall 'current-module ()))))))) + +(define (fold-formals proc seed arity gensyms inits) + (match arity + (($ $arity req opt rest kw allow-other-keys?) + (let () + (define (fold-req names gensyms seed) + (match names + (() (fold-opt opt gensyms inits seed)) + ((name . names) + (proc name (car gensyms) #f + (fold-req names (cdr gensyms) seed))))) + (define (fold-opt names gensyms inits seed) + (match names + (() (fold-rest rest gensyms inits seed)) + ((name . names) + (proc name (car gensyms) (car inits) + (fold-opt names (cdr gensyms) (cdr inits) seed))))) + (define (fold-rest rest gensyms inits seed) + (match rest + (#f (fold-kw kw gensyms inits seed)) + (name (proc name (car gensyms) #f + (fold-kw kw (cdr gensyms) inits seed))))) + (define (fold-kw kw gensyms inits seed) + (match kw + (() + (unless (null? gensyms) + (error "too many gensyms")) + (unless (null? inits) + (error "too many inits")) + seed) + (((key name var) . kw) + (unless (eq? var (car gensyms)) + (error "unexpected keyword arg order")) + (proc name var (car inits) + (fold-kw kw (cdr gensyms) (cdr inits) seed))))) + (fold-req req gensyms seed))))) + +(define (unbound? src sym kt kf) + (define tc8-iflag 4) + (define unbound-val 9) + (define unbound-bits (logior (ash unbound-val 8) tc8-iflag)) + (let-gensyms (unbound ktest) + (build-cps-term + ($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits)))) + ($letk ((ktest src ($kif kt kf))) + ($continue ktest + ($primcall 'eq? (sym unbound)))))))) + +(define (init-default-value name sym subst init body) + (match (assq-ref subst sym) + ((subst-sym box?) + (let ((src (tree-il-src init))) + (define (maybe-box k make-body) + (if box? + (let-gensyms (kbox phi) + (build-cps-term + ($letk ((kbox src ($kargs (name) (phi) + ($continue k ($primcall 'box (phi)))))) + ,(make-body kbox)))) + (make-body k))) + (let-gensyms (knext kbound kunbound) + (build-cps-term + ($letk ((knext src ($kargs (name) (subst-sym) ,body))) + ,(maybe-box + knext + (lambda (k) + (build-cps-term + ($letk ((kbound src ($kargs () () ($continue k ($var sym)))) + (kunbound src ($kargs () () ,(convert init k subst)))) + ,(unbound? src sym kunbound kbound)))))))))))) + +;; exp k-name alist -> term +(define (convert exp k subst) + ;; exp (v-name -> term) -> term + (define (convert-arg exp k) + (match exp + (($ <lexical-ref> src name sym) + (match (assq-ref subst sym) + ((box #t) + (let-gensyms (kunboxed unboxed) + (build-cps-term + ($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k unboxed)))) + ($continue kunboxed ($primcall 'box-ref (box))))))) + ((subst #f) (k subst)) + (#f (k sym)))) + (else + (let ((src (tree-il-src exp))) + (let-gensyms (karg arg) + (build-cps-term + ($letk ((karg src ($kargs ('arg) (arg) ,(k arg)))) + ,(convert exp karg subst)))))))) + ;; (exp ...) ((v-name ...) -> term) -> term + (define (convert-args exps k) + (match exps + (() (k '())) + ((exp . exps) + (convert-arg exp + (lambda (name) + (convert-args exps + (lambda (names) + (k (cons name names))))))))) + (define (box-bound-var name sym body) + (match (assq-ref subst sym) + ((box #t) + (let-gensyms (k) + (build-cps-term + ($letk ((k #f ($kargs (name) (box) ,body))) + ($continue k ($primcall 'box (sym))))))) + (else body))) + + (match exp + (($ <lexical-ref> src name sym) + (match (assq-ref subst sym) + ((box #t) (build-cps-term ($continue k ($primcall 'box-ref (box))))) + ((subst #f) (build-cps-term ($continue k ($var subst)))) + (#f (build-cps-term ($continue k ($var sym)))))) + + (($ <void> src) + (build-cps-term ($continue k ($void)))) + + (($ <const> src exp) + (build-cps-term ($continue k ($const exp)))) + + (($ <primitive-ref> src name) + (build-cps-term ($continue k ($prim name)))) + + (($ <lambda> fun-src meta body) + (let () + (define (convert-clauses body ktail) + (match body + (#f '()) + (($ <lambda-case> src req opt rest kw inits gensyms body alternate) + (let* ((arity (make-$arity req (or opt '()) rest + (if kw (cdr kw) '()) (and kw (car kw)))) + (names (fold-formals (lambda (name sym init names) + (cons name names)) + '() + arity gensyms inits))) + (cons + (let-gensyms (kclause kargs) + (build-cps-cont + (kclause + src + ($kclause ,arity + (kargs + src + ($kargs names gensyms + ,(fold-formals + (lambda (name sym init body) + (if init + (init-default-value name sym subst init body) + (box-bound-var name sym body))) + (convert body ktail subst) + arity gensyms inits))))))) + (convert-clauses alternate ktail)))))) + (if (current-topbox-scope) + (let-gensyms (kentry self ktail) + (build-cps-term + ($continue k + ($fun meta '() + (kentry fun-src + ($kentry self (ktail #f ($ktail)) + ,(convert-clauses body ktail))))))) + (let-gensyms (scope kscope) + (build-cps-term + ($letk ((kscope fun-src + ($kargs () () + ,(parameterize ((current-topbox-scope scope)) + (convert exp k subst))))) + ,(capture-toplevel-scope fun-src scope kscope))))))) + + (($ <module-ref> src mod name public?) + (module-box + src mod name public? #t + (lambda (box) + (build-cps-term ($continue k ($primcall 'box-ref (box))))))) + + (($ <module-set> src mod name public? exp) + (convert-arg exp + (lambda (val) + (module-box + src mod name public? #f + (lambda (box) + (build-cps-term ($continue k ($primcall 'box-set! (box val))))))))) + + (($ <toplevel-ref> src name) + (toplevel-box + src name #t + (lambda (box) + (build-cps-term ($continue k ($primcall 'box-ref (box))))))) + + (($ <toplevel-set> src name exp) + (convert-arg exp + (lambda (val) + (toplevel-box + src name #f + (lambda (box) + (build-cps-term ($continue k ($primcall 'box-set! (box val))))))))) + + (($ <toplevel-define> src name exp) + (convert-arg exp + (lambda (val) + (let-gensyms (kname name-sym) + (build-cps-term + ($letconst (('name name-sym name)) + ($continue k ($primcall 'define! (name-sym val))))))))) + + (($ <call> src proc args) + (convert-args (cons proc args) + (match-lambda + ((proc . args) + (build-cps-term ($continue k ($call proc args))))))) + + (($ <primcall> src name args) + (case name + ((list) + (convert (fold-right (lambda (elem tail) + (make-primcall src 'cons + (list elem tail))) + (make-const src '()) + args) + k subst)) + (else + (if (branching-primitive? name) + (convert (make-conditional src exp (make-const #f #t) + (make-const #f #f)) + k subst) + (convert-args args + (lambda (args) + (if (eq? name 'values) + (build-cps-term ($continue k ($values args))) + (build-cps-term ($continue k ($primcall name args)))))))))) + + ;; Prompts with inline handlers. + (($ <prompt> src escape-only? tag body + ($ <lambda> hsrc hmeta + ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f))) + ;; Handler: + ;; khargs: check args returned to handler, -> khbody + ;; khbody: the handler, -> k + ;; + ;; Post-body: + ;; krest: collect return vals from body to list, -> kpop + ;; kpop: pop the prompt, -> kprim + ;; kprim: load the values primitive, -> kret + ;; kret: (apply values rvals), -> k + ;; + ;; Escape prompts evaluate the body with the continuation of krest. + ;; Otherwise we do a no-inline call to body, continuing to krest. + (convert-arg tag + (lambda (tag) + (let ((hnames (append hreq (if hrest (list hrest) '())))) + (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody) + (build-cps-term + ($letk* ((khbody hsrc ($kargs hnames hsyms + ,(fold box-bound-var + (convert hbody k subst) + hnames hsyms))) + (khargs hsrc ($ktrunc hreq hrest khbody)) + (kpop src + ($kargs ('rest) (vals) + ($letk ((kret + src + ($kargs () () + ($letk ((kprim + src + ($kargs ('prim) (prim) + ($continue k + ($primcall 'apply + (prim vals)))))) + ($continue kprim + ($prim 'values)))))) + ($continue kret + ($primcall 'pop-prompt ()))))) + (krest src ($ktrunc '() 'rest kpop))) + ,(if escape-only? + (build-cps-term + ($letk ((kbody (tree-il-src body) + ($kargs () () + ,(convert body krest subst)))) + ($continue kbody ($prompt #t tag khargs)))) + (convert-arg body + (lambda (thunk) + (build-cps-term + ($letk ((kbody (tree-il-src body) + ($kargs () () + ($continue krest + ($primcall 'call-thunk/no-inline + (thunk)))))) + ($continue kbody + ($prompt #f tag khargs)))))))))))))) + + ;; Eta-convert prompts without inline handlers. + (($ <prompt> src escape-only? tag body handler) + (convert-args (list tag body handler) + (lambda (args) + (build-cps-term + ($continue k ($primcall 'call-with-prompt args)))))) + + (($ <abort> src tag args tail) + (convert-args (append (list tag) args (list tail)) + (lambda (args*) + (build-cps-term ($continue k ($primcall 'abort args*)))))) + + (($ <conditional> src test consequent alternate) + (let-gensyms (kif kt kf) + (build-cps-term + ($letk* ((kt (tree-il-src consequent) ($kargs () () + ,(convert consequent k subst))) + (kf (tree-il-src alternate) ($kargs () () + ,(convert alternate k subst))) + (kif src ($kif kt kf))) + ,(match test + (($ <primcall> src (? branching-primitive? name) args) + (convert-args args + (lambda (args) + (build-cps-term ($continue kif ($primcall name args)))))) + (_ (convert-arg test + (lambda (test) + (build-cps-term ($continue kif ($var test))))))))))) + + (($ <lexical-set> src name gensym exp) + (convert-arg exp + (lambda (exp) + (match (assq-ref subst gensym) + ((box #t) + (build-cps-term + ($continue k ($primcall 'box-set! (box exp))))))))) + + (($ <seq> src head tail) + (let-gensyms (ktrunc kseq) + (build-cps-term + ($letk* ((kseq (tree-il-src tail) ($kargs () () + ,(convert tail k subst))) + (ktrunc src ($ktrunc '() #f kseq))) + ,(convert head ktrunc subst))))) + + (($ <let> src names syms vals body) + (let lp ((names names) (syms syms) (vals vals)) + (match (list names syms vals) + ((() () ()) (convert body k subst)) + (((name . names) (sym . syms) (val . vals)) + (let-gensyms (klet) + (build-cps-term + ($letk ((klet src ($kargs (name) (sym) + ,(box-bound-var name sym + (lp names syms vals))))) + ,(convert val klet subst)))))))) + + (($ <fix> src names gensyms funs body) + ;; Some letrecs can be contified; that happens later. + (if (current-topbox-scope) + (let-gensyms (self) + (build-cps-term + ($letrec names + gensyms + (map (lambda (fun) + (match (convert fun k subst) + (($ $continue _ (and fun ($ $fun))) + fun))) + funs) + ,(convert body k subst)))) + (let-gensyms (scope kscope) + (build-cps-term + ($letk ((kscope src ($kargs () () + ,(parameterize ((current-topbox-scope scope)) + (convert exp k subst))))) + ,(capture-toplevel-scope src scope kscope)))))) + + (($ <let-values> src exp + ($ <lambda-case> lsrc req #f rest #f () syms body #f)) + (let ((names (append req (if rest (list rest) '())))) + (let-gensyms (ktrunc kargs) + (build-cps-term + ($letk* ((kargs src ($kargs names syms + ,(fold box-bound-var + (convert body k subst) + names syms))) + (ktrunc src ($ktrunc req rest kargs))) + ,(convert exp ktrunc subst)))))))) + +(define (build-subst exp) + "Compute a mapping from lexical gensyms to substituted gensyms. The +usual reason to replace one variable by another is assignment +conversion. Default argument values is the other reason. + +Returns a list of (ORIG-SYM SUBST-SYM BOXED?). A true value for BOXED? +indicates that the replacement variable is in a box." + (define (box-set-vars exp subst) + (match exp + (($ <lexical-set> src name sym exp) + (if (assq sym subst) + subst + (cons (list sym (gensym "b") #t) subst))) + (_ subst))) + (define (default-args exp subst) + (match exp + (($ <lambda-case> src req opt rest kw inits gensyms body alternate) + (fold-formals (lambda (name sym init subst) + (if init + (let ((box? (match (assq-ref subst sym) + ((box #t) #t) + (#f #f))) + (subst-sym (gensym (symbol->string name)))) + (cons (list sym subst-sym box?) subst)) + subst)) + subst + (make-$arity req (or opt '()) rest + (if kw (cdr kw) '()) (and kw (car kw))) + gensyms + inits)) + (_ subst))) + (tree-il-fold box-set-vars default-args '() exp)) + +(define (cps-convert/thunk exp) + (let ((src (tree-il-src exp))) + (let-gensyms (kinit init ktail kclause kbody) + (build-cps-exp + ($fun '() '() + (kinit src + ($kentry init + (ktail #f ($ktail)) + ((kclause src + ($kclause ('() '() #f '() #f) + (kbody src + ($kargs () () + ,(convert exp ktail + (build-subst exp)))))))))))))) + +(define *comp-module* (make-fluid)) + +(define %warning-passes + `((unused-variable . ,unused-variable-analysis) + (unused-toplevel . ,unused-toplevel-analysis) + (unbound-variable . ,unbound-variable-analysis) + (arity-mismatch . ,arity-analysis) + (format . ,format-analysis))) + +(define (optimize-tree-il x e opts) + (define warnings + (or (and=> (memq #:warnings opts) cadr) + '())) + + ;; Go through the warning passes. + (let ((analyses (filter-map (lambda (kind) + (assoc-ref %warning-passes kind)) + warnings))) + (analyze-tree analyses x e)) + + (optimize x e opts)) + +(define (compile-cps exp env opts) + (values (cps-convert/thunk (optimize-tree-il exp env opts)) + env + env)) + +;;; Local Variables: +;;; eval: (put 'convert-arg 'scheme-indent-function 1) +;;; eval: (put 'convert-args 'scheme-indent-function 1) +;;; End: diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm index 80c32fe29..a574eb237 100644 --- a/module/language/tree-il/spec.scm +++ b/module/language/tree-il/spec.scm @@ -23,6 +23,7 @@ #:use-module (system base pmatch) #:use-module (language glil) #:use-module (language tree-il) + #:use-module (language tree-il compile-cps) #:use-module (language tree-il compile-glil) #:export (tree-il)) @@ -43,6 +44,7 @@ #:printer write-tree-il #:parser parse-tree-il #:joiner join - #:compilers `((glil . ,compile-glil)) + #:compilers `((glil . ,compile-glil) + (cps . ,compile-cps)) #:for-humans? #f ) |