mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
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.
This commit is contained in:
Andy Wingo
parent
9833c545cc
commit
b31af02faf
5 changed files with 0 additions and 957 deletions
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue