[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 07/07: Consolidate CPS2 above CPS in the compiler
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 07/07: Consolidate CPS2 above CPS in the compiler |
|
Date: |
Mon, 11 May 2015 20:46:13 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit b31af02faf93b9197bc2bb19a67c71f3e984a064
Author: Andy Wingo <address@hidden>
Date: Mon May 11 22:34:13 2015 +0200
Consolidate CPS2 above CPS in the compiler
This is an intermediate step. We'll replace CPS bit by bit. If it
turns out to be a terrible idea we can just revert.
* module/Makefile.am (TREE_IL_LANG_SOURCES): Remove compile-cps.scm.
(CPS_LANG_SOURCES): Remove arities.scm.
* module/language/cps/arities.scm: Remove.
* module/language/tree-il/compile-cps.scm: Remove.
* module/language/tree-il/spec.scm: Remove use of compile-cps.scm.
* module/language/cps/compile-bytecode.scm: Remove use of arities.scm.
Instead, incoming terms are expected to call their continuations
with the correct number of arguments.
---
module/Makefile.am | 2 -
module/language/cps/arities.scm | 201 --------
module/language/cps/compile-bytecode.scm | 2 -
module/language/tree-il/compile-cps.scm | 751 ------------------------------
module/language/tree-il/spec.scm | 1 -
5 files changed, 0 insertions(+), 957 deletions(-)
diff --git a/module/Makefile.am b/module/Makefile.am
index b86efc7..8c4480f 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -117,13 +117,11 @@ TREE_IL_LANG_SOURCES =
\
language/tree-il/analyze.scm \
language/tree-il/inline.scm \
language/tree-il/compile-cps2.scm \
- language/tree-il/compile-cps.scm \
language/tree-il/debug.scm \
language/tree-il/spec.scm
CPS_LANG_SOURCES = \
language/cps.scm \
- language/cps/arities.scm \
language/cps/closure-conversion.scm \
language/cps/compile-bytecode.scm \
language/cps/constructors.scm \
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
deleted file mode 100644
index fa7cc14..0000000
--- a/module/language/cps/arities.scm
+++ /dev/null
@@ -1,201 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 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:
-;;;
-;;; A pass to adapt expressions to the arities of their continuations,
-;;; and to rewrite some tail expressions as primcalls to "return".
-;;;
-;;; Code:
-
-(define-module (language cps arities)
- #:use-module (ice-9 match)
- #:use-module ((srfi srfi-1) #:select (fold))
- #:use-module (srfi srfi-26)
- #:use-module (language cps)
- #:use-module (language cps dfg)
- #:use-module (language cps primitives)
- #:export (fix-arities))
-
-(define (fix-arities* clause dfg)
- (let ((ktail (match clause
- (($ $cont _
- ($ $kfun src meta _ ($ $cont ktail) _)) ktail))))
- (define (visit-term term)
- (rewrite-cps-term term
- (($ $letk conts body)
- ($letk ,(map visit-cont conts) ,(visit-term body)))
- (($ $continue k src exp)
- ,(visit-exp k src exp))))
-
- (define (adapt-exp nvals k src exp)
- (match nvals
- (0
- (rewrite-cps-term (lookup-cont k dfg)
- (($ $ktail)
- ,(let-fresh (kvoid kunspec) (unspec)
- (build-cps-term
- ($letk* ((kunspec ($kargs (unspec) (unspec)
- ($continue k src
- ($primcall 'return (unspec)))))
- (kvoid ($kargs () ()
- ($continue kunspec src
- ($const *unspecified*)))))
- ($continue kvoid src ,exp)))))
- (($ $kreceive arity kargs)
- ,(match arity
- (($ $arity () () rest () #f)
- (if rest
- (let-fresh (knil) ()
- (build-cps-term
- ($letk ((knil ($kargs () ()
- ($continue kargs src ($const '())))))
- ($continue knil src ,exp))))
- (build-cps-term
- ($continue kargs src ,exp))))
- (_
- (let-fresh (kvoid kvalues) (void)
- (build-cps-term
- ($letk* ((kvalues ($kargs ('void) (void)
- ($continue k src
- ($primcall 'values (void)))))
- (kvoid ($kargs () ()
- ($continue kvalues src
- ($const *unspecified*)))))
- ($continue kvoid src ,exp)))))))
- (($ $kargs () () _)
- ($continue k src ,exp))
- (_
- ,(let-fresh (k*) ()
- (build-cps-term
- ($letk ((k* ($kargs () () ($continue k src
- ($const *unspecified*)))))
- ($continue k* src ,exp)))))))
- (1
- (rewrite-cps-term (lookup-cont k dfg)
- (($ $ktail)
- ,(rewrite-cps-term exp
- (($ $values (sym))
- ($continue ktail src ($primcall 'return (sym))))
- (_
- ,(let-fresh (k*) (v)
- (build-cps-term
- ($letk ((k* ($kargs (v) (v)
- ($continue k src
- ($primcall 'return (v))))))
- ($continue k* src ,exp)))))))
- (($ $kreceive arity kargs)
- ,(match arity
- (($ $arity (_) () rest () #f)
- (if rest
- (let-fresh (kval) (val nil)
- (build-cps-term
- ($letk ((kval ($kargs ('val) (val)
- ($letconst (('nil nil '()))
- ($continue kargs src
- ($values (val nil)))))))
- ($continue kval src ,exp))))
- (build-cps-term ($continue kargs src ,exp))))
- (_
- (let-fresh (kvalues) (value)
- (build-cps-term
- ($letk ((kvalues ($kargs ('value) (value)
- ($continue k src
- ($primcall 'values (value))))))
- ($continue kvalues src ,exp)))))))
- (($ $kargs () () _)
- ,(let-fresh (k*) (drop)
- (build-cps-term
- ($letk ((k* ($kargs ('drop) (drop)
- ($continue k src ($values ())))))
- ($continue k* src ,exp)))))
- (_
- ($continue k src ,exp))))))
-
- (define (visit-exp k src exp)
- (rewrite-cps-term exp
- ((or ($ $const)
- ($ $prim)
- ($ $values (_)))
- ,(adapt-exp 1 k src exp))
- (($ $fun body)
- ,(adapt-exp 1 k src (build-cps-exp
- ($fun ,(fix-arities* body dfg)))))
- (($ $rec names syms funs)
- ;; Assume $rec expressions have the correct arity.
- ($continue k src
- ($rec names syms (map (lambda (fun)
- (rewrite-cps-exp fun
- (($ $fun body)
- ($fun ,(fix-arities* body dfg)))))
- funs))))
- ((or ($ $call) ($ $callk))
- ;; In general, calls have unknown return arity. For that
- ;; reason every non-tail call has a $kreceive continuation to
- ;; adapt the return to the target continuation, and we don't
- ;; need to do any adapting here.
- ($continue k src ,exp))
- (($ $branch)
- ;; Assume branching primcalls have the correct arity.
- ($continue k src ,exp))
- (($ $primcall 'return (arg))
- ;; Primcalls to return are in tail position.
- ($continue ktail src ,exp))
- (($ $primcall (? (lambda (name)
- (and (not (prim-instruction name))
- (not (branching-primitive? name))))))
- ($continue k src ,exp))
- (($ $primcall name args)
- ,(match (prim-arity name)
- ((out . in)
- (if (= in (length args))
- (adapt-exp out k src
- (let ((inst (prim-instruction name)))
- (if (and inst (not (eq? inst name)))
- (build-cps-exp ($primcall inst args))
- exp)))
- (let-fresh (k*) (p*)
- (build-cps-term
- ($letk ((k* ($kargs ('prim) (p*)
- ($continue k src ($call p* args)))))
- ($continue k* src ($prim name)))))))))
- (($ $values)
- ;; Non-unary values nodes are inserted by CPS optimization
- ;; passes, so we assume they are correct.
- ($continue k src ,exp))
- (($ $prompt)
- ($continue k src ,exp))))
-
- (define (visit-cont cont)
- (rewrite-cps-cont cont
- (($ $cont sym ($ $kargs names syms body))
- (sym ($kargs names syms ,(visit-term body))))
- (($ $cont sym ($ $kclause arity body alternate))
- (sym ($kclause ,arity ,(visit-cont body)
- ,(and alternate (visit-cont alternate)))))
- (($ $cont)
- ,cont)))
-
- (rewrite-cps-cont clause
- (($ $cont sym ($ $kfun src meta self tail clause))
- (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause))))))))
-
-(define (fix-arities fun)
- (let ((dfg (compute-dfg fun)))
- (with-fresh-name-state-from-dfg dfg
- (fix-arities* fun dfg))))
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 9c33fa2..2248c26 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -27,7 +27,6 @@
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (language cps)
- #:use-module (language cps arities)
#:use-module (language cps closure-conversion)
#:use-module (language cps contification)
#:use-module (language cps constructors)
@@ -508,7 +507,6 @@
(define (compile-bytecode exp env opts)
;; See comment in `optimize' about the use of set!.
- (set! exp (fix-arities exp))
(set! exp (optimize exp opts))
(set! exp (convert-closures exp))
;; first-order optimization should go here
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
deleted file mode 100644
index 4e515f7..0000000
--- a/module/language/tree-il/compile-cps.scm
+++ /dev/null
@@ -1,751 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 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)
- #: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 scope-counter (make-parameter #f))
-
-(define (fresh-scope-id)
- (let ((scope-id (scope-counter)))
- (scope-counter (1+ scope-id))
- scope-id))
-
-(define (toplevel-box src name bound? val-proc)
- (let-fresh (kbox) (name-sym bound?-sym box)
- (build-cps-term
- ($letconst (('name name-sym name)
- ('bound? bound?-sym bound?))
- ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
- ,(match (current-topbox-scope)
- (#f
- (build-cps-term
- ($continue kbox src
- ($primcall 'resolve
- (name-sym bound?-sym)))))
- (scope-id
- (let-fresh () (scope-sym)
- (build-cps-term
- ($letconst (('scope scope-sym scope-id))
- ($continue kbox src
- ($primcall 'cached-toplevel-box
- (scope-sym name-sym bound?-sym)))))))))))))
-
-(define (module-box src module name public? bound? val-proc)
- (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
- (build-cps-term
- ($letconst (('module module-sym module)
- ('name name-sym name)
- ('public? public?-sym public?)
- ('bound? bound?-sym bound?))
- ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
- ($continue kbox src
- ($primcall 'cached-module-box
- (module-sym name-sym public?-sym bound?-sym))))))))
-
-(define (capture-toplevel-scope src scope-id k)
- (let-fresh (kmodule) (module scope-sym)
- (build-cps-term
- ($letconst (('scope scope-sym scope-id))
- ($letk ((kmodule ($kargs ('module) (module)
- ($continue k src
- ($primcall 'cache-current-module!
- (module scope-sym))))))
- ($continue kmodule src
- ($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)
- ;; Could be that var is not a gensym any more.
- (when (symbol? var)
- (unless (eq? var (car gensyms))
- (error "unexpected keyword arg order")))
- (proc name (car gensyms) (car inits)
- (fold-kw kw (cdr gensyms) (cdr inits) seed)))))
- (fold-req req gensyms seed)))))
-
-(define (unbound? src var kt kf)
- (define tc8-iflag 4)
- (define unbound-val 9)
- (define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
- (let-fresh () (unbound)
- (build-cps-term
- ($letconst (('unbound unbound
- (pointer->scm (make-pointer unbound-bits))))
- ($continue kf src
- ($branch kt ($primcall 'eq? (var unbound))))))))
-
-(define (init-default-value name sym subst init body)
- (match (hashq-ref subst sym)
- ((orig-var subst-var box?)
- (let ((src (tree-il-src init)))
- (define (maybe-box k make-body)
- (if box?
- (let-fresh (kbox) (phi)
- (build-cps-term
- ($letk ((kbox ($kargs (name) (phi)
- ($continue k src ($primcall 'box (phi))))))
- ,(make-body kbox))))
- (make-body k)))
- (let-fresh (knext kbound kunbound kreceive krest) (val rest)
- (build-cps-term
- ($letk ((knext ($kargs (name) (subst-var) ,body)))
- ,(maybe-box
- knext
- (lambda (k)
- (build-cps-term
- ($letk ((kbound ($kargs () () ($continue k src
- ($values (orig-var)))))
- (krest ($kargs (name 'rest) (val rest)
- ($continue k src ($values (val)))))
- (kreceive ($kreceive (list name) 'rest krest))
- (kunbound ($kargs () ()
- ,(convert init kreceive subst))))
- ,(unbound? src orig-var 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 (hashq-ref subst sym)
- ((orig-var box #t)
- (let-fresh (kunboxed) (unboxed)
- (build-cps-term
- ($letk ((kunboxed ($kargs ('unboxed) (unboxed) ,(k unboxed))))
- ($continue kunboxed src ($primcall 'box-ref (box)))))))
- ((orig-var subst-var #f) (k subst-var))
- (var (k var))))
- (else
- (let-fresh (kreceive karg) (arg rest)
- (build-cps-term
- ($letk ((karg ($kargs ('arg 'rest) (arg rest) ,(k arg)))
- (kreceive ($kreceive '(arg) 'rest karg)))
- ,(convert exp kreceive 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 (hashq-ref subst sym)
- ((orig-var subst-var #t)
- (let-fresh (k) ()
- (build-cps-term
- ($letk ((k ($kargs (name) (subst-var) ,body)))
- ($continue k #f ($primcall 'box (orig-var)))))))
- (else body)))
- (define (bound-var sym)
- (match (hashq-ref subst sym)
- ((var . _) var)
- ((? exact-integer? var) var)))
-
- (match exp
- (($ <lexical-ref> src name sym)
- (rewrite-cps-term (hashq-ref subst sym)
- ((orig-var box #t) ($continue k src ($primcall 'box-ref (box))))
- ((orig-var subst-var #f) ($continue k src ($values (subst-var))))
- (var ($continue k src ($values (var))))))
-
- (($ <void> src)
- (build-cps-term ($continue k src ($const *unspecified*))))
-
- (($ <const> src exp)
- (build-cps-term ($continue k src ($const exp))))
-
- (($ <primitive-ref> src name)
- (build-cps-term ($continue k src ($prim name))))
-
- (($ <lambda> fun-src meta body)
- (let ()
- (define (convert-clauses body ktail)
- (match body
- (#f #f)
- (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
- (let* ((arity (make-$arity req (or opt '()) rest
- (map (match-lambda
- ((kw name sym)
- (list kw name (bound-var sym))))
- (if kw (cdr kw) '()))
- (and kw (car kw))))
- (names (fold-formals (lambda (name sym init names)
- (cons name names))
- '()
- arity gensyms inits)))
- (let ((bound-vars (map bound-var gensyms)))
- (let-fresh (kclause kargs) ()
- (build-cps-cont
- (kclause
- ($kclause ,arity
- (kargs
- ($kargs names bound-vars
- ,(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-fresh (kfun ktail) (self)
- (build-cps-term
- ($continue k fun-src
- ($fun
- (kfun ($kfun fun-src meta self (ktail ($ktail))
- ,(convert-clauses body ktail)))))))
- (let ((scope-id (fresh-scope-id)))
- (let-fresh (kscope) ()
- (build-cps-term
- ($letk ((kscope
- ($kargs () ()
- ,(parameterize ((current-topbox-scope scope-id))
- (convert exp k subst)))))
- ,(capture-toplevel-scope fun-src scope-id kscope))))))))
-
- (($ <module-ref> src mod name public?)
- (module-box
- src mod name public? #t
- (lambda (box)
- (build-cps-term ($continue k src ($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 src ($primcall 'box-set! (box val)))))))))
-
- (($ <toplevel-ref> src name)
- (toplevel-box
- src name #t
- (lambda (box)
- (build-cps-term ($continue k src ($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 src ($primcall 'box-set! (box val)))))))))
-
- (($ <toplevel-define> src name exp)
- (convert-arg exp
- (lambda (val)
- (let-fresh (kname) (name-sym)
- (build-cps-term
- ($letconst (('name name-sym name))
- ($continue k src ($primcall 'define! (name-sym val)))))))))
-
- (($ <call> src proc args)
- (convert-args (cons proc args)
- (match-lambda
- ((proc . args)
- (build-cps-term ($continue k src ($call proc args)))))))
-
- (($ <primcall> src name args)
- (cond
- ((branching-primitive? name)
- (convert-args args
- (lambda (args)
- (let-fresh (kt kf) ()
- (build-cps-term
- ($letk ((kt ($kargs () () ($continue k src ($const #t))))
- (kf ($kargs () () ($continue k src ($const #f)))))
- ($continue kf src
- ($branch kt ($primcall name args)))))))))
- ((and (eq? name 'not) (match args ((_) #t) (_ #f)))
- (convert-args args
- (lambda (args)
- (let-fresh (kt kf) ()
- (build-cps-term
- ($letk ((kt ($kargs () () ($continue k src ($const #f))))
- (kf ($kargs () () ($continue k src ($const #t)))))
- ($continue kf src
- ($branch kt ($values args)))))))))
- ((and (eq? name 'list)
- (and-map (match-lambda
- ((or ($ <const>)
- ($ <void>)
- ($ <lambda>)
- ($ <lexical-ref>)) #t)
- (_ #f))
- args))
- ;; See note below in `canonicalize' about `vector'. The same
- ;; thing applies to `list'.
- (let lp ((args args) (k k))
- (match args
- (()
- (build-cps-term
- ($continue k src ($const '()))))
- ((arg . args)
- (let-fresh (ktail) (tail)
- (build-cps-term
- ($letk ((ktail ($kargs ('tail) (tail)
- ,(convert-arg arg
- (lambda (head)
- (build-cps-term
- ($continue k src
- ($primcall 'cons (head tail)))))))))
- ,(lp args ktail))))))))
- (else
- (convert-args args
- (lambda (args)
- (build-cps-term ($continue k src ($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) '())))
- (bound-vars (map bound-var hsyms)))
- (let-fresh (khargs khbody kret kprim kpop krest kbody) (prim vals)
- (build-cps-term
- ;; FIXME: Attach hsrc to $kreceive.
- ($letk* ((khbody ($kargs hnames bound-vars
- ,(fold box-bound-var
- (convert hbody k subst)
- hnames hsyms)))
- (khargs ($kreceive hreq hrest khbody))
- (kpop ($kargs ('rest) (vals)
- ($letk ((kret
- ($kargs () ()
- ($letk ((kprim
- ($kargs ('prim) (prim)
- ($continue k src
- ($primcall 'apply
- (prim
vals))))))
- ($continue kprim src
- ($prim 'values))))))
- ($continue kret src
- ($primcall 'unwind ())))))
- (krest ($kreceive '() 'rest kpop)))
- ,(if escape-only?
- (build-cps-term
- ($letk ((kbody ($kargs () ()
- ,(convert body krest subst))))
- ($continue kbody src ($prompt #t tag khargs))))
- (convert-arg body
- (lambda (thunk)
- (build-cps-term
- ($letk ((kbody ($kargs () ()
- ($continue krest (tree-il-src
body)
- ($primcall 'call-thunk/no-inline
- (thunk))))))
- ($continue kbody (tree-il-src body)
- ($prompt #f tag khargs))))))))))))))
-
- (($ <abort> src tag args ($ <const> _ ()))
- (convert-args (cons tag args)
- (lambda (args*)
- (build-cps-term
- ($continue k src
- ($primcall 'abort-to-prompt args*))))))
-
- (($ <abort> src tag args tail)
- (convert-args (append (list (make-primitive-ref #f 'abort-to-prompt)
- tag)
- args
- (list tail))
- (lambda (args*)
- (build-cps-term
- ($continue k src ($primcall 'apply args*))))))
-
- (($ <conditional> src test consequent alternate)
- (let-fresh (kt kf) ()
- (build-cps-term
- ($letk* ((kt ($kargs () () ,(convert consequent k subst)))
- (kf ($kargs () () ,(convert alternate k subst))))
- ,(match test
- (($ <primcall> src (? branching-primitive? name) args)
- (convert-args args
- (lambda (args)
- (build-cps-term
- ($continue kf src
- ($branch kt ($primcall name args)))))))
- (_ (convert-arg test
- (lambda (test)
- (build-cps-term
- ($continue kf src
- ($branch kt ($values (test)))))))))))))
-
- (($ <lexical-set> src name gensym exp)
- (convert-arg exp
- (lambda (exp)
- (match (hashq-ref subst gensym)
- ((orig-var box #t)
- (build-cps-term
- ($continue k src ($primcall 'box-set! (box exp)))))))))
-
- (($ <seq> src head tail)
- (let-fresh (kreceive kseq) (vals)
- (build-cps-term
- ($letk* ((kseq ($kargs ('vals) (vals)
- ,(convert tail k subst)))
- (kreceive ($kreceive '() 'vals kseq)))
- ,(convert head kreceive 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-fresh (kreceive klet) (rest)
- (build-cps-term
- ($letk* ((klet ($kargs (name 'rest) ((bound-var sym) rest)
- ,(box-bound-var name sym
- (lp names syms vals))))
- (kreceive ($kreceive (list name) 'rest klet)))
- ,(convert val kreceive subst))))))))
-
- (($ <fix> src names gensyms funs body)
- ;; Some letrecs can be contified; that happens later.
- (if (current-topbox-scope)
- (let ((vars (map bound-var gensyms)))
- (let-fresh (krec) ()
- (build-cps-term
- ($letk ((krec ($kargs names vars
- ,(convert body k subst))))
- ($continue krec src
- ($rec names vars
- (map (lambda (fun)
- (match (convert fun k subst)
- (($ $continue _ _ (and fun ($ $fun)))
- fun)))
- funs)))))))
- (let ((scope-id (fresh-scope-id)))
- (let-fresh (kscope) ()
- (build-cps-term
- ($letk ((kscope
- ($kargs () ()
- ,(parameterize ((current-topbox-scope scope-id))
- (convert exp k subst)))))
- ,(capture-toplevel-scope src scope-id kscope)))))))
-
- (($ <let-values> src exp
- ($ <lambda-case> lsrc req #f rest #f () syms body #f))
- (let ((names (append req (if rest (list rest) '())))
- (bound-vars (map bound-var syms)))
- (let-fresh (kreceive kargs) ()
- (build-cps-term
- ($letk* ((kargs ($kargs names bound-vars
- ,(fold box-bound-var
- (convert body k subst)
- names syms)))
- (kreceive ($kreceive req rest kargs)))
- ,(convert exp kreceive subst))))))))
-
-(define (build-subst exp)
- "Compute a mapping from lexical gensyms to CPS variable indexes. CPS
-uses small integers to identify variables, instead of gensyms.
-
-This subst table serves an additional purpose of mapping variables to
-replacements. The usual reason to replace one variable by another is
-assignment conversion. Default argument values is the other reason.
-
-The result is a hash table mapping symbols to substitutions (in the case
-that a variable is substituted) or to indexes. A substitution is a list
-of the form:
-
- (ORIG-INDEX SUBST-INDEX BOXED?)
-
-A true value for BOXED? indicates that the replacement variable is in a
-box. If a variable is not substituted, the mapped value is a small
-integer."
- (let ((table (make-hash-table)))
- (define (down exp)
- (match exp
- (($ <lexical-set> src name sym exp)
- (match (hashq-ref table sym)
- ((orig subst #t) #t)
- ((orig subst #f) (hashq-set! table sym (list orig subst #t)))
- ((? number? idx) (hashq-set! table sym (list idx (fresh-var) #t)))))
- (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
- (fold-formals (lambda (name sym init seed)
- (hashq-set! table sym
- (if init
- (list (fresh-var) (fresh-var) #f)
- (fresh-var))))
- #f
- (make-$arity req (or opt '()) rest
- (if kw (cdr kw) '()) (and kw (car kw)))
- gensyms
- inits))
- (($ <let> src names gensyms vals body)
- (for-each (lambda (sym)
- (hashq-set! table sym (fresh-var)))
- gensyms))
- (($ <fix> src names gensyms vals body)
- (for-each (lambda (sym)
- (hashq-set! table sym (fresh-var)))
- gensyms))
- (_ #t))
- (values))
- (define (up exp) (values))
- ((make-tree-il-folder) exp down up)
- table))
-
-(define (cps-convert/thunk exp)
- (parameterize ((label-counter 0)
- (var-counter 0)
- (scope-counter 0))
- (let ((src (tree-il-src exp)))
- (let-fresh (kinit ktail kclause kbody) (init)
- (build-cps-cont
- (kinit ($kfun src '() init (ktail ($ktail))
- (kclause
- ($kclause ('() '() #f '() #f)
- (kbody ($kargs () ()
- ,(convert exp ktail
- (build-subst exp))))
- ,#f)))))))))
-
-(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 (canonicalize exp)
- (post-order
- (lambda (exp)
- (match exp
- (($ <primcall> src 'vector
- (and args
- ((or ($ <const>) ($ <void>) ($ <lambda>) ($ <lexical-ref>))
- ...)))
- ;; Some macros generate calls to "vector" with like 300
- ;; arguments. Since we eventually compile to make-vector and
- ;; vector-set!, it reduces live variable pressure to allocate the
- ;; vector first, then set values as they are produced, if we can
- ;; prove that no value can capture the continuation. (More on
- ;; that caveat here:
- ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time).
- ;;
- ;; Normally we would do this transformation in the compiler, but
- ;; it's quite tricky there and quite easy here, so hold your nose
- ;; while we drop some smelly code.
- (let ((len (length args))
- (v (gensym "v ")))
- (make-let src
- (list 'v)
- (list v)
- (list (make-primcall src 'make-vector
- (list (make-const #f len)
- (make-const #f #f))))
- (fold (lambda (arg n tail)
- (make-seq
- src
- (make-primcall
- src 'vector-set!
- (list (make-lexical-ref src 'v v)
- (make-const #f n)
- arg))
- tail))
- (make-lexical-ref src 'v v)
- (reverse args) (reverse (iota len))))))
-
- (($ <primcall> src 'struct-set! (struct index value))
- ;; Unhappily, and undocumentedly, struct-set! returns the value
- ;; that was set. There is code that relies on this. Hackety
- ;; hack...
- (let ((v (gensym "v ")))
- (make-let src
- (list 'v)
- (list v)
- (list value)
- (make-seq src
- (make-primcall src 'struct-set!
- (list struct
- index
- (make-lexical-ref src 'v
v)))
- (make-lexical-ref src 'v v)))))
-
- (($ <prompt> src escape-only? tag body
- ($ <lambda> hsrc hmeta
- ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
- exp)
-
- ;; Eta-convert prompts without inline handlers.
- (($ <prompt> src escape-only? tag body handler)
- (let ((h (gensym "h "))
- (args (gensym "args ")))
- (make-let
- src (list 'h) (list h) (list handler)
- (make-seq
- src
- (make-conditional
- src
- (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
- (make-void src)
- (make-primcall
- src 'scm-error
- (list
- (make-const #f 'wrong-type-arg)
- (make-const #f "call-with-prompt")
- (make-const #f "Wrong type (expecting procedure): ~S")
- (make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
- (make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
- (make-prompt
- src escape-only? tag body
- (make-lambda
- src '()
- (make-lambda-case
- src '() #f 'args #f '() (list args)
- (make-primcall
- src 'apply
- (list (make-lexical-ref #f 'h h)
- (make-lexical-ref #f 'args args)))
- #f)))))))
- (_ exp)))
- exp))
-
-(define (compile-cps exp env opts)
- (values (cps-convert/thunk
- (canonicalize (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 f783de3..d1c7326 100644
--- a/module/language/tree-il/spec.scm
+++ b/module/language/tree-il/spec.scm
@@ -22,7 +22,6 @@
#:use-module (system base language)
#:use-module (system base pmatch)
#:use-module (language tree-il)
- #:use-module (language tree-il compile-cps)
#:use-module (language tree-il compile-cps2)
#:export (tree-il))
- [Guile-commits] branch master updated (d99fedc -> b31af02), Andy Wingo, 2015/05/11
- [Guile-commits] 01/07: Fix intset-add! transient bug, Andy Wingo, 2015/05/11
- [Guile-commits] 02/07: Fix another intset transient bug, Andy Wingo, 2015/05/11
- [Guile-commits] 03/07: compute-dom-edges returns a persistent intmap, Andy Wingo, 2015/05/11
- [Guile-commits] 04/07: Tree-IL -> CPS2 -> CPS, Andy Wingo, 2015/05/11
- [Guile-commits] 06/07: Adapt return arities in Tree-IL -> CPS2 conversion, Andy Wingo, 2015/05/11
- [Guile-commits] 05/07: Build CPS2 with transient intmaps, Andy Wingo, 2015/05/11
- [Guile-commits] 07/07: Consolidate CPS2 above CPS in the compiler,
Andy Wingo <=