Beginnings of CPS2 language.
The tentative plan is to replace CPS with CPS2, and to rename CPS2 to CPS. We will add a pass to compile tree-il to CPS2, then work from the top down to replace the CPS compiler passes. * module/language/cps2.scm: * module/language/cps2/compile-cps.scm: * module/language/cps2/renumber.scm: * module/language/cps2/utils.scm: New files. * module/Makefile.am: Add new files to build.
This commit is contained in:
Andy Wingo
parent
6ffb6e69ed
commit
6485e89276
6 changed files with 923 additions and 0 deletions
|
|
@ -21,6 +21,12 @@
|
|||
(eval . (put 'rewrite-cps-term 'scheme-indent-function 1))
|
||||
(eval . (put 'rewrite-cps-cont 'scheme-indent-function 1))
|
||||
(eval . (put 'rewrite-cps-exp 'scheme-indent-function 1))
|
||||
(eval . (put 'build-term 'scheme-indent-function 0))
|
||||
(eval . (put 'build-exp 'scheme-indent-function 0))
|
||||
(eval . (put 'build-cont 'scheme-indent-function 0))
|
||||
(eval . (put 'rewrite-term 'scheme-indent-function 1))
|
||||
(eval . (put 'rewrite-cont 'scheme-indent-function 1))
|
||||
(eval . (put 'rewrite-exp 'scheme-indent-function 1))
|
||||
(eval . (put '$letk 'scheme-indent-function 1))
|
||||
(eval . (put '$letk* 'scheme-indent-function 1))
|
||||
(eval . (put '$letconst 'scheme-indent-function 1))
|
||||
|
|
|
|||
|
|
@ -59,6 +59,7 @@ SOURCES = \
|
|||
\
|
||||
language/tree-il.scm \
|
||||
$(TREE_IL_LANG_SOURCES) \
|
||||
$(CPS2_LANG_SOURCES) \
|
||||
$(CPS_LANG_SOURCES) \
|
||||
$(BYTECODE_LANG_SOURCES) \
|
||||
$(VALUE_LANG_SOURCES) \
|
||||
|
|
@ -147,6 +148,12 @@ CPS_LANG_SOURCES = \
|
|||
language/cps/type-fold.scm \
|
||||
language/cps/verify.scm
|
||||
|
||||
CPS2_LANG_SOURCES = \
|
||||
language/cps2.scm \
|
||||
language/cps2/compile-cps.scm \
|
||||
language/cps2/renumber.scm \
|
||||
language/cps2/utils.scm
|
||||
|
||||
BYTECODE_LANG_SOURCES = \
|
||||
language/bytecode.scm \
|
||||
language/bytecode/spec.scm
|
||||
|
|
|
|||
362
module/language/cps2.scm
Normal file
362
module/language/cps2.scm
Normal file
|
|
@ -0,0 +1,362 @@
|
|||
;;; 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:
|
||||
;;;
|
||||
;;; [Transitional note: CPS2 is a new version of CPS, and is a bit of an
|
||||
;;; experiment. All of the comments in this file pretend that CPS2 will
|
||||
;;; replace CPS, and will be named CPS.]
|
||||
;;;
|
||||
;;; This is the continuation-passing style (CPS) intermediate language
|
||||
;;; (IL) for Guile.
|
||||
;;;
|
||||
;;; In CPS, a term is a labelled expression that calls a continuation.
|
||||
;;; A function is a collection of terms. No term belongs to more than
|
||||
;;; one function. The function is identified by the label of its entry
|
||||
;;; term, and its body is composed of those terms that are reachable
|
||||
;;; from the entry term. A program is a collection of functions,
|
||||
;;; identified by the entry label of the entry function.
|
||||
;;;
|
||||
;;; Terms are themselves wrapped in continuations, which specify how
|
||||
;;; predecessors may continue to them. For example, a $kargs
|
||||
;;; continuation specifies that the term may be called with a specific
|
||||
;;; number of values, and that those values will then be bound to
|
||||
;;; lexical variables. $kreceive specifies that some number of values
|
||||
;;; will be passed on the stack, as from a multiple-value return. Those
|
||||
;;; values will be passed to a $kargs, if the number of values is
|
||||
;;; compatible with the $kreceive's arity. $kfun is an entry point to a
|
||||
;;; function, and receives arguments according to a well-known calling
|
||||
;;; convention (currently, on the stack) and the stack before
|
||||
;;; dispatching to a $kclause. A $kclause is a case-lambda clause, and
|
||||
;;; only appears within a $kfun; it checks the incoming values for the
|
||||
;;; correct arity and dispatches to a $kargs, or to the next clause.
|
||||
;;; Finally, $ktail is the tail continuation for a function, and
|
||||
;;; contains no term.
|
||||
;;;
|
||||
;;; Each continuation has a label that is unique in the program. As an
|
||||
;;; implementation detail, the labels are integers, which allows us to
|
||||
;;; easily sort them topologically. A program is a map from integers to
|
||||
;;; continuations, where continuation 0 in the map is the entry point
|
||||
;;; for the program, and is a $kfun of no arguments.
|
||||
;;;
|
||||
;;; $continue nodes call continuations. The expression contained in the
|
||||
;;; $continue node determines the value or values that are passed to the
|
||||
;;; target continuation: $const to pass a constant value, $values to
|
||||
;;; pass multiple named values, etc. $continue nodes also record the
|
||||
;;; source location corresponding to the expression.
|
||||
;;;
|
||||
;;; As mentioned above, a $kargs continuation can bind variables, if it
|
||||
;;; receives incoming values. $kfun also binds a value, corresponding
|
||||
;;; to the closure being called. A traditional CPS implementation will
|
||||
;;; nest terms in each other, binding them in "let" forms, ensuring that
|
||||
;;; continuations are declared and bound within the scope of the values
|
||||
;;; that they may use. In this way, the scope tree is a proof that
|
||||
;;; variables are defined before they are used. However, this proof is
|
||||
;;; conservative; it is possible for a variable to always be defined
|
||||
;;; before it is used, but not to be in scope:
|
||||
;;;
|
||||
;;; (letrec ((k1 (lambda (v1) (k2)))
|
||||
;;; (k2 (lambda () v1)))
|
||||
;;; (k1 0))
|
||||
;;;
|
||||
;;; This example is invalid, as v1 is used outside its scope. However
|
||||
;;; it would be perfectly fine for k2 to use v1 if k2 were nested inside
|
||||
;;; k1:
|
||||
;;;
|
||||
;;; (letrec ((k1 (lambda (v1)
|
||||
;;; (letrec ((k2 (lambda () v1)))
|
||||
;;; (k2))))
|
||||
;;; (k1 0))
|
||||
;;;
|
||||
;;; Because program transformation usually uses flow-based analysis,
|
||||
;;; having to update the scope tree to manifestly prove a transformation
|
||||
;;; that has already proven correct is needless overhead, and in the
|
||||
;;; worst case can prevent optimizations from occuring. For that
|
||||
;;; reason, Guile's CPS language does not nest terms. Instead, we use
|
||||
;;; the invariant that definitions must dominate uses. To check the
|
||||
;;; validity of a CPS program is thus more involved than checking for a
|
||||
;;; well-scoped tree; you have to do flow analysis to determine a
|
||||
;;; dominator tree. However the flexibility that this grants us is
|
||||
;;; worth the cost of throwing away the embedded proof of the scope
|
||||
;;; tree.
|
||||
;;;
|
||||
;;; This particular formulation of CPS was inspired by Andrew Kennedy's
|
||||
;;; 2007 paper, "Compiling with Continuations, Continued". All Guile
|
||||
;;; hackers should read that excellent paper! As in Kennedy's paper,
|
||||
;;; continuations are second-class, and may be thought of as basic block
|
||||
;;; labels. All values are bound to variables using continuation calls:
|
||||
;;; even constants!
|
||||
;;;
|
||||
;;; Finally, note that there are two flavors of CPS: higher-order and
|
||||
;;; first-order. By "higher-order", we mean that variables may be free
|
||||
;;; across function boundaries. Higher-order CPS contains $fun and $rec
|
||||
;;; expressions that declare functions in the scope of their term.
|
||||
;;; Closure conversion results in first-order CPS, where closure
|
||||
;;; representations have been explicitly chosen, and all variables used
|
||||
;;; in a function are bound. Higher-order CPS is good for
|
||||
;;; interprocedural optimizations like contification and beta reduction,
|
||||
;;; while first-order CPS is better for instruction selection, register
|
||||
;;; allocation, and code generation.
|
||||
;;;
|
||||
;;; See (language tree-il compile-cps) for details on how Tree-IL
|
||||
;;; converts to CPS.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define-module (language cps2)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-9 gnu)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:export (;; Helper.
|
||||
$arity
|
||||
make-$arity
|
||||
|
||||
;; Continuations.
|
||||
$kreceive $kargs $kfun $ktail $kclause
|
||||
|
||||
;; Terms.
|
||||
$continue
|
||||
|
||||
;; Expressions.
|
||||
$const $prim $fun $rec $closure $branch
|
||||
$call $callk $primcall $values $prompt
|
||||
|
||||
;; Building macros.
|
||||
build-cont build-term build-exp
|
||||
rewrite-cont rewrite-term rewrite-exp
|
||||
|
||||
;; External representation.
|
||||
parse-cps unparse-cps))
|
||||
|
||||
;; FIXME: Use SRFI-99, when Guile adds it.
|
||||
(define-syntax define-record-type*
|
||||
(lambda (x)
|
||||
(define (id-append ctx . syms)
|
||||
(datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
|
||||
(syntax-case x ()
|
||||
((_ name field ...)
|
||||
(and (identifier? #'name) (and-map identifier? #'(field ...)))
|
||||
(with-syntax ((cons (id-append #'name #'make- #'name))
|
||||
(pred (id-append #'name #'name #'?))
|
||||
((getter ...) (map (lambda (f)
|
||||
(id-append f #'name #'- f))
|
||||
#'(field ...))))
|
||||
#'(define-record-type name
|
||||
(cons field ...)
|
||||
pred
|
||||
(field getter)
|
||||
...))))))
|
||||
|
||||
(define-syntax-rule (define-cps-type name field ...)
|
||||
(begin
|
||||
(define-record-type* name field ...)
|
||||
(set-record-type-printer! name print-cps)))
|
||||
|
||||
(define (print-cps exp port)
|
||||
(format port "#<cps ~S>" (unparse-cps exp)))
|
||||
|
||||
;; Helper.
|
||||
(define-record-type* $arity req opt rest kw allow-other-keys?)
|
||||
|
||||
;; Continuations
|
||||
(define-cps-type $kreceive arity kbody)
|
||||
(define-cps-type $kargs names syms term)
|
||||
(define-cps-type $kfun src meta self ktail kclause)
|
||||
(define-cps-type $ktail)
|
||||
(define-cps-type $kclause arity kbody kalternate)
|
||||
|
||||
;; Terms.
|
||||
(define-cps-type $continue k src exp)
|
||||
|
||||
;; Expressions.
|
||||
(define-cps-type $const val)
|
||||
(define-cps-type $prim name)
|
||||
(define-cps-type $fun body) ; Higher-order.
|
||||
(define-cps-type $rec names syms funs) ; Higher-order.
|
||||
(define-cps-type $closure label nfree) ; First-order.
|
||||
(define-cps-type $branch kt exp)
|
||||
(define-cps-type $call proc args)
|
||||
(define-cps-type $callk k proc args) ; First-order.
|
||||
(define-cps-type $primcall name args)
|
||||
(define-cps-type $values args)
|
||||
(define-cps-type $prompt escape? tag handler)
|
||||
|
||||
(define-syntax build-arity
|
||||
(syntax-rules (unquote)
|
||||
((_ (unquote exp)) exp)
|
||||
((_ (req opt rest kw allow-other-keys?))
|
||||
(make-$arity req opt rest kw allow-other-keys?))))
|
||||
|
||||
(define-syntax build-cont
|
||||
(syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause)
|
||||
((_ (unquote exp))
|
||||
exp)
|
||||
((_ ($kreceive req rest kargs))
|
||||
(make-$kreceive (make-$arity req '() rest '() #f) kargs))
|
||||
((_ ($kargs (name ...) (unquote syms) body))
|
||||
(make-$kargs (list name ...) syms (build-term body)))
|
||||
((_ ($kargs (name ...) (sym ...) body))
|
||||
(make-$kargs (list name ...) (list sym ...) (build-term body)))
|
||||
((_ ($kargs names syms body))
|
||||
(make-$kargs names syms (build-term body)))
|
||||
((_ ($kfun src meta self ktail kclause))
|
||||
(make-$kfun src meta self ktail kclause))
|
||||
((_ ($ktail))
|
||||
(make-$ktail))
|
||||
((_ ($kclause arity kbody kalternate))
|
||||
(make-$kclause (build-arity arity) kbody kalternate))))
|
||||
|
||||
(define-syntax build-term
|
||||
(syntax-rules (unquote $rec $continue)
|
||||
((_ (unquote exp))
|
||||
exp)
|
||||
((_ ($continue k src exp))
|
||||
(make-$continue k src (build-exp exp)))))
|
||||
|
||||
(define-syntax build-exp
|
||||
(syntax-rules (unquote
|
||||
$const $prim $fun $rec $closure $branch
|
||||
$call $callk $primcall $values $prompt)
|
||||
((_ (unquote exp)) exp)
|
||||
((_ ($const val)) (make-$const val))
|
||||
((_ ($prim name)) (make-$prim name))
|
||||
((_ ($fun kentry)) (make-$fun kentry))
|
||||
((_ ($rec names gensyms funs)) (make-$rec names gensyms funs))
|
||||
((_ ($closure k nfree)) (make-$closure k nfree))
|
||||
((_ ($call proc (unquote args))) (make-$call proc args))
|
||||
((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
|
||||
((_ ($call proc args)) (make-$call proc args))
|
||||
((_ ($callk k proc (unquote args))) (make-$callk k proc args))
|
||||
((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...)))
|
||||
((_ ($callk k proc args)) (make-$callk k proc args))
|
||||
((_ ($primcall name (unquote args))) (make-$primcall name args))
|
||||
((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
|
||||
((_ ($primcall name args)) (make-$primcall name args))
|
||||
((_ ($values (unquote args))) (make-$values args))
|
||||
((_ ($values (arg ...))) (make-$values (list arg ...)))
|
||||
((_ ($values args)) (make-$values args))
|
||||
((_ ($branch kt exp)) (make-$branch kt (build-exp exp)))
|
||||
((_ ($prompt escape? tag handler))
|
||||
(make-$prompt escape? tag handler))))
|
||||
|
||||
(define-syntax-rule (rewrite-cont x (pat cont) ...)
|
||||
(match x
|
||||
(pat (build-cont cont)) ...))
|
||||
(define-syntax-rule (rewrite-term x (pat term) ...)
|
||||
(match x
|
||||
(pat (build-term term)) ...))
|
||||
(define-syntax-rule (rewrite-exp x (pat body) ...)
|
||||
(match x
|
||||
(pat (build-exp body)) ...))
|
||||
|
||||
(define (parse-cps exp)
|
||||
(define (src exp)
|
||||
(let ((props (source-properties exp)))
|
||||
(and (pair? props) props)))
|
||||
(match exp
|
||||
;; Continuations.
|
||||
(('kreceive req rest k)
|
||||
(build-cont ($kreceive req rest k)))
|
||||
(('kargs names syms body)
|
||||
(build-cont ($kargs names syms ,(parse-cps body))))
|
||||
(('kfun src meta self ktail kclause)
|
||||
(build-cont ($kfun (src exp) meta self ktail kclause)))
|
||||
(('ktail)
|
||||
(build-cont ($ktail)))
|
||||
(('kclause (req opt rest kw allow-other-keys?) kbody)
|
||||
(build-cont ($kclause (req opt rest kw allow-other-keys?) kbody #f)))
|
||||
(('kclause (req opt rest kw allow-other-keys?) kbody kalt)
|
||||
(build-cont ($kclause (req opt rest kw allow-other-keys?) kbody kalt)))
|
||||
|
||||
;; Calls.
|
||||
(('continue k exp)
|
||||
(build-term ($continue k (src exp) ,(parse-cps exp))))
|
||||
(('unspecified)
|
||||
(build-exp ($const *unspecified*)))
|
||||
(('const exp)
|
||||
(build-exp ($const exp)))
|
||||
(('prim name)
|
||||
(build-exp ($prim name)))
|
||||
(('fun kbody)
|
||||
(build-exp ($fun kbody)))
|
||||
(('closure k nfree)
|
||||
(build-exp ($closure k nfree)))
|
||||
(('rec (name sym fun) ...)
|
||||
(build-exp ($rec name sym (map parse-cps fun))))
|
||||
(('call proc arg ...)
|
||||
(build-exp ($call proc arg)))
|
||||
(('callk k proc arg ...)
|
||||
(build-exp ($callk k proc arg)))
|
||||
(('primcall name arg ...)
|
||||
(build-exp ($primcall name arg)))
|
||||
(('branch k exp)
|
||||
(build-exp ($branch k ,(parse-cps exp))))
|
||||
(('values arg ...)
|
||||
(build-exp ($values arg)))
|
||||
(('prompt escape? tag handler)
|
||||
(build-cps-exp ($prompt escape? tag handler)))
|
||||
(_
|
||||
(error "unexpected cps" exp))))
|
||||
|
||||
(define (unparse-cps exp)
|
||||
(match exp
|
||||
;; Continuations.
|
||||
(($ $kreceive ($ $arity req () rest () #f) k)
|
||||
`(kreceive ,req ,rest ,k))
|
||||
(($ $kargs names syms body)
|
||||
`(kargs ,names ,syms ,(unparse-cps body)))
|
||||
(($ $kfun src meta self ktail kclause)
|
||||
`(kfun ,meta ,self ,ktail ,kclause))
|
||||
(($ $ktail)
|
||||
`(ktail))
|
||||
(($ $kclause ($ $arity req opt rest kw allow-other-keys?) kbody kalternate)
|
||||
`(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,kbody
|
||||
. ,(if kalternate (list kalternate) '())))
|
||||
|
||||
;; Calls.
|
||||
(($ $continue k src exp)
|
||||
`(continue ,k ,(unparse-cps exp)))
|
||||
(($ $const val)
|
||||
(if (unspecified? val)
|
||||
'(unspecified)
|
||||
`(const ,val)))
|
||||
(($ $prim name)
|
||||
`(prim ,name))
|
||||
(($ $fun kbody)
|
||||
`(fun ,kbody))
|
||||
(($ $closure k nfree)
|
||||
`(closure ,k ,nfree))
|
||||
(($ $rec names syms funs)
|
||||
`(rec ,@(map (lambda (name sym fun)
|
||||
(list name sym (unparse-cps fun)))
|
||||
names syms funs)))
|
||||
(($ $call proc args)
|
||||
`(call ,proc ,@args))
|
||||
(($ $callk k proc args)
|
||||
`(callk ,k ,proc ,@args))
|
||||
(($ $primcall name args)
|
||||
`(primcall ,name ,@args))
|
||||
(($ $branch k exp)
|
||||
`(branch ,k ,(unparse-cps exp)))
|
||||
(($ $values args)
|
||||
`(values ,@args))
|
||||
(($ $prompt escape? tag handler)
|
||||
`(prompt ,escape? ,tag ,handler))
|
||||
(_
|
||||
(error "unexpected cps" exp))))
|
||||
102
module/language/cps2/compile-cps.scm
Normal file
102
module/language/cps2/compile-cps.scm
Normal file
|
|
@ -0,0 +1,102 @@
|
|||
;;; 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:
|
||||
;;;
|
||||
;;; Compiling CPS2 to CPS. When/if CPS2 replaces CPS, this module will be removed.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define-module (language cps2 compile-cps)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (language cps2)
|
||||
#:use-module ((language cps) #:prefix cps:)
|
||||
#:use-module (language cps2 utils)
|
||||
#:use-module (language cps2 renumber)
|
||||
#:use-module (language cps intmap)
|
||||
#:export (compile-cps))
|
||||
|
||||
;; Precondition: For each function in CONTS, the continuation names are
|
||||
;; topologically sorted.
|
||||
(define (conts->fun conts)
|
||||
(define (convert-fun kfun)
|
||||
(let ((doms (compute-dom-edges (compute-idoms conts kfun))))
|
||||
(define (visit-cont label)
|
||||
(cps:rewrite-cps-cont (intmap-ref conts label)
|
||||
(($ $kargs names syms body)
|
||||
(label (cps:$kargs names syms ,(redominate label (visit-term body)))))
|
||||
(($ $ktail)
|
||||
(label (cps:$ktail)))
|
||||
(($ $kreceive ($ $arity req () rest () #f) kargs)
|
||||
(label (cps:$kreceive req rest kargs)))))
|
||||
(define (visit-clause label)
|
||||
(and label
|
||||
(cps:rewrite-cps-cont (intmap-ref conts label)
|
||||
(($ $kclause ($ $arity req opt rest kw aok?) kbody kalt)
|
||||
(label (cps:$kclause (req opt rest kw aok?)
|
||||
,(visit-cont kbody)
|
||||
,(visit-clause kalt)))))))
|
||||
(define (redominate label term)
|
||||
(define (visit-dom-conts label)
|
||||
(match (intmap-ref conts label)
|
||||
(($ $ktail) '())
|
||||
(($ $kargs) (list (visit-cont label)))
|
||||
(else
|
||||
(cons (visit-cont label)
|
||||
(visit-dom-conts* (intmap-ref doms label))))))
|
||||
(define (visit-dom-conts* labels)
|
||||
(match labels
|
||||
(() '())
|
||||
((label . labels)
|
||||
(append (visit-dom-conts label)
|
||||
(visit-dom-conts* labels)))))
|
||||
(cps:rewrite-cps-term (visit-dom-conts* (intmap-ref doms label))
|
||||
(() ,term)
|
||||
(conts (cps:$letk ,conts ,term))))
|
||||
(define (visit-term term)
|
||||
(cps:rewrite-cps-term term
|
||||
(($ $continue k src (and ($ $fun) fun))
|
||||
(cps:$continue k src ,(visit-fun fun)))
|
||||
(($ $continue k src ($ $rec names syms funs))
|
||||
(cps:$continue k src (cps:$rec names syms (map visit-fun funs))))
|
||||
(($ $continue k src exp)
|
||||
(cps:$continue k src ,(visit-exp exp)))))
|
||||
(define (visit-exp exp)
|
||||
(cps:rewrite-cps-exp exp
|
||||
(($ $const val) (cps:$const val))
|
||||
(($ $prim name) (cps:$prim name))
|
||||
(($ $closure k nfree) (cps:$closure k nfree))
|
||||
(($ $call proc args) (cps:$call proc args))
|
||||
(($ $callk k proc args) (cps:$callk k proc args))
|
||||
(($ $primcall name args) (cps:$primcall name args))
|
||||
(($ $branch k exp) (cps:$branch k ,(visit-exp exp)))
|
||||
(($ $values args) (cps:$values args))
|
||||
(($ $prompt escape? tag handler) (cps:$prompt escape? tag handler))))
|
||||
(define (visit-fun fun)
|
||||
(cps:rewrite-cps-exp fun
|
||||
(($ $fun body)
|
||||
(cps:$fun ,(convert-fun body)))))
|
||||
|
||||
(cps:rewrite-cps-cont (intmap-ref conts kfun)
|
||||
(($ $kfun src meta self tail clause)
|
||||
(kfun (cps:$kfun src meta self (tail (cps:$ktail))
|
||||
,(visit-clause clause)))))))
|
||||
(convert-fun 0))
|
||||
|
||||
(define (compile-cps exp env opts)
|
||||
(values (conts->fun (renumber exp)) env env))
|
||||
218
module/language/cps2/renumber.scm
Normal file
218
module/language/cps2/renumber.scm
Normal file
|
|
@ -0,0 +1,218 @@
|
|||
;;; 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 renumber variables and continuation labels so that they
|
||||
;;; are contiguous within each function and, in the case of labels,
|
||||
;;; topologically sorted.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define-module (language cps2 renumber)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:use-module (language cps2)
|
||||
#:use-module (language cps2 utils)
|
||||
#:use-module (language cps intset)
|
||||
#:use-module (language cps intmap)
|
||||
#:export (renumber))
|
||||
|
||||
(define* (compute-tail-path-lengths conts kfun preds)
|
||||
(define (add-lengths labels lengths length)
|
||||
(intset-fold (lambda (label lengths)
|
||||
(intmap-add! lengths label length))
|
||||
labels
|
||||
lengths))
|
||||
(define (compute-next labels lengths)
|
||||
(intset-fold (lambda (label labels)
|
||||
(fold1 (lambda (pred labels)
|
||||
(if (intmap-ref lengths pred)
|
||||
labels
|
||||
(intset-add! labels pred)))
|
||||
(intmap-ref preds label)
|
||||
labels))
|
||||
labels
|
||||
empty-intset))
|
||||
(define (visit labels lengths length)
|
||||
(let ((lengths (add-lengths labels lengths length)))
|
||||
(values (compute-next labels lengths) lengths (1+ length))))
|
||||
(match (intmap-ref conts kfun)
|
||||
(($ $kfun src meta self tail clause)
|
||||
(worklist-fold2 visit (intset-add empty-intset tail) empty-intmap 0))))
|
||||
|
||||
;; Topologically sort the continuation tree starting at k0, using
|
||||
;; reverse post-order numbering.
|
||||
(define (sort-labels-locally conts k0 path-lengths)
|
||||
(let ((order '())
|
||||
(visited empty-intset))
|
||||
(define (visit k)
|
||||
(define (maybe-visit k)
|
||||
(unless (intset-ref visited k)
|
||||
(visit k)))
|
||||
(define (visit-successors k)
|
||||
(match (intmap-ref conts k)
|
||||
(($ $kargs names syms ($ $continue k src exp))
|
||||
(match exp
|
||||
(($ $prompt escape? tag handler)
|
||||
(maybe-visit handler)
|
||||
(maybe-visit k))
|
||||
(($ $branch kt)
|
||||
;; Visit the successor with the shortest path length
|
||||
;; to the tail first, so that if the branches are
|
||||
;; unsorted, the longer path length will appear
|
||||
;; first. This will move a loop exit out of a loop.
|
||||
(let ((k-len (intmap-ref path-lengths k))
|
||||
(kt-len (intmap-ref path-lengths kt)))
|
||||
(cond
|
||||
((if kt-len
|
||||
(or (not k-len)
|
||||
(< k-len kt-len)
|
||||
;; If the path lengths are the
|
||||
;; same, preserve original order
|
||||
;; to avoid squirreliness.
|
||||
(and (= k-len kt-len) (< kt k)))
|
||||
(if k-len #f (< kt k)))
|
||||
(maybe-visit k)
|
||||
(maybe-visit kt))
|
||||
(else
|
||||
(maybe-visit kt)
|
||||
(maybe-visit k)))))
|
||||
(_
|
||||
(maybe-visit k))))
|
||||
(($ $kreceive arity k) (maybe-visit k))
|
||||
(($ $kclause arity kbody kalt)
|
||||
(when kalt (visit kalt))
|
||||
(maybe-visit kbody))
|
||||
(($ $kfun src meta self tail clause)
|
||||
(visit tail)
|
||||
(when clause (visit clause)))
|
||||
(_ #f)))
|
||||
|
||||
;; Mark this continuation as visited.
|
||||
(set! visited (intset-add! visited k))
|
||||
|
||||
;; Visit unvisited successors.
|
||||
(visit-successors k)
|
||||
|
||||
;; Add k to the reverse post-order.
|
||||
(set! order (cons k order)))
|
||||
|
||||
;; Recursively visit all continuations reachable from k0.
|
||||
(visit k0)
|
||||
|
||||
;; Return the sorted order.
|
||||
order))
|
||||
|
||||
(define (compute-renaming conts kfun)
|
||||
;; labels := old -> new
|
||||
;; vars := old -> new
|
||||
(define *next-label* -1)
|
||||
(define *next-var* -1)
|
||||
(define (rename-label label labels)
|
||||
(set! *next-label* (1+ *next-label*))
|
||||
(intmap-add! labels label *next-label*))
|
||||
(define (rename-var sym vars)
|
||||
(set! *next-var* (1+ *next-var*))
|
||||
(intmap-add! vars sym *next-var*))
|
||||
(define (rename label labels vars)
|
||||
(values (rename-label label labels)
|
||||
(match (intmap-ref conts label)
|
||||
(($ $kargs names syms exp)
|
||||
(fold1 rename-var syms vars))
|
||||
(($ $kfun src meta self tail clause)
|
||||
(rename-var self vars))
|
||||
(_ vars))))
|
||||
(define (visit-nested-funs k labels vars)
|
||||
(match (intmap-ref conts k)
|
||||
(($ $kargs names syms ($ $continue k src ($ $fun kfun)))
|
||||
(visit-fun kfun labels vars))
|
||||
(($ $kargs names syms ($ $continue k src ($ $rec names* syms*
|
||||
(($ $fun kfun) ...))))
|
||||
(fold2 visit-fun kfun labels vars))
|
||||
(_ (values labels vars))))
|
||||
(define (visit-fun kfun labels vars)
|
||||
(let* ((preds (compute-predecessors conts kfun))
|
||||
(path-lengths (compute-tail-path-lengths conts kfun preds))
|
||||
(order (sort-labels-locally conts kfun path-lengths)))
|
||||
;; First rename locally, then recurse on nested functions.
|
||||
(let-values (((labels vars) (fold2 rename order labels vars)))
|
||||
(fold2 visit-nested-funs order labels vars))))
|
||||
(let-values (((labels vars) (visit-fun kfun empty-intmap empty-intmap)))
|
||||
(values (persistent-intmap labels) (persistent-intmap vars))))
|
||||
|
||||
(define* (renumber conts #:optional (kfun 0))
|
||||
(let-values (((label-map var-map) (compute-renaming conts kfun)))
|
||||
(define (rename-label label)
|
||||
(or (intmap-ref label-map label) (error "what" label)))
|
||||
(define (rename-var var)
|
||||
(or (intmap-ref var-map var) (error "what2" var)))
|
||||
(define (rename-exp exp)
|
||||
(rewrite-exp exp
|
||||
((or ($ $const) ($ $prim)) ,exp)
|
||||
(($ $closure k nfree)
|
||||
($closure (rename-label k) nfree))
|
||||
(($ $fun body)
|
||||
($fun (rename-label body)))
|
||||
(($ $rec names vars funs)
|
||||
($rec names (map rename-var vars) (map rename-exp funs)))
|
||||
(($ $values args)
|
||||
($values ,(map rename-var args)))
|
||||
(($ $call proc args)
|
||||
($call (rename-var proc) ,(map rename-var args)))
|
||||
(($ $callk k proc args)
|
||||
($callk (rename-label k) (rename-var proc) ,(map rename-var args)))
|
||||
(($ $branch kt exp)
|
||||
($branch (rename-label kt) ,(rename-exp exp)))
|
||||
(($ $primcall name args)
|
||||
($primcall name ,(map rename-var args)))
|
||||
(($ $prompt escape? tag handler)
|
||||
($prompt escape? (rename-var tag) (rename-label handler)))))
|
||||
(define (rename-arity arity)
|
||||
(match arity
|
||||
(($ $arity req opt rest () aok?)
|
||||
arity)
|
||||
(($ $arity req opt rest kw aok?)
|
||||
(match kw
|
||||
(() arity)
|
||||
(((kw kw-name kw-var) ...)
|
||||
(let ((kw (map list kw kw-name (map rename-var kw-var))))
|
||||
(make-$arity req opt rest kw aok?)))))))
|
||||
(persistent-intmap
|
||||
(intmap-fold
|
||||
(lambda (old-k new-k out)
|
||||
(intmap-add!
|
||||
out
|
||||
new-k
|
||||
(rewrite-cont (intmap-ref conts old-k)
|
||||
(($ $kargs names syms ($ $continue k src exp))
|
||||
($kargs names (map rename-var syms)
|
||||
($continue (rename-label k) src ,(rename-exp exp))))
|
||||
(($ $kreceive ($ $arity req () rest () #f) k)
|
||||
($kreceive req rest (rename-label k)))
|
||||
(($ $ktail)
|
||||
($ktail))
|
||||
(($ $kfun src meta self tail clause)
|
||||
($kfun src meta (rename-var self) (rename-label tail)
|
||||
(and clause (rename-label clause))))
|
||||
(($ $kclause arity body alternate)
|
||||
($kclause ,(rename-arity arity) (rename-label body)
|
||||
(and alternate (rename-label alternate)))))))
|
||||
label-map
|
||||
empty-intmap))))
|
||||
228
module/language/cps2/utils.scm
Normal file
228
module/language/cps2/utils.scm
Normal file
|
|
@ -0,0 +1,228 @@
|
|||
;;; 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:
|
||||
;;;
|
||||
;;; Helper facilities for working with CPS.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define-module (language cps2 utils)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:use-module (language cps2)
|
||||
#:use-module (language cps intset)
|
||||
#:use-module (language cps intmap)
|
||||
#:export (;; Fresh names.
|
||||
label-counter var-counter
|
||||
fresh-label fresh-var
|
||||
with-fresh-name-state compute-max-label-and-var
|
||||
let-fresh
|
||||
|
||||
;; Various utilities.
|
||||
fold1 fold2
|
||||
intset->intmap
|
||||
worklist-fold worklist-fold2
|
||||
fixpoint
|
||||
|
||||
;; Flow analysis.
|
||||
compute-predecessors
|
||||
compute-function-body
|
||||
compute-idoms
|
||||
compute-dom-edges
|
||||
))
|
||||
|
||||
(define label-counter (make-parameter #f))
|
||||
(define var-counter (make-parameter #f))
|
||||
|
||||
(define (fresh-label)
|
||||
(let ((count (or (label-counter)
|
||||
(error "fresh-label outside with-fresh-name-state"))))
|
||||
(label-counter (1+ count))
|
||||
count))
|
||||
|
||||
(define (fresh-var)
|
||||
(let ((count (or (var-counter)
|
||||
(error "fresh-var outside with-fresh-name-state"))))
|
||||
(var-counter (1+ count))
|
||||
count))
|
||||
|
||||
(define-syntax-rule (let-fresh (label ...) (var ...) body ...)
|
||||
(let* ((label (fresh-label)) ...
|
||||
(var (fresh-var)) ...)
|
||||
body ...))
|
||||
|
||||
(define-syntax-rule (with-fresh-name-state fun body ...)
|
||||
(call-with-values (lambda () (compute-max-label-and-var fun))
|
||||
(lambda (max-label max-var)
|
||||
(parameterize ((label-counter (1+ max-label))
|
||||
(var-counter (1+ max-var)))
|
||||
body ...))))
|
||||
|
||||
(define (compute-max-label-and-var conts)
|
||||
(values (or (intmap-prev conts) -1)
|
||||
(intmap-fold (lambda (k cont max-var)
|
||||
(match cont
|
||||
(($ $kargs names syms body)
|
||||
(apply max max-var syms))
|
||||
(($ $kfun src meta self)
|
||||
(max max-var self))
|
||||
(_ max-var)))
|
||||
conts
|
||||
-1)))
|
||||
|
||||
(define-inlinable (fold1 f l s0)
|
||||
(let lp ((l l) (s0 s0))
|
||||
(match l
|
||||
(() s0)
|
||||
((elt . l) (lp l (f elt s0))))))
|
||||
|
||||
(define-inlinable (fold2 f l s0 s1)
|
||||
(let lp ((l l) (s0 s0) (s1 s1))
|
||||
(match l
|
||||
(() (values s0 s1))
|
||||
((elt . l)
|
||||
(call-with-values (lambda () (f elt s0 s1))
|
||||
(lambda (s0 s1)
|
||||
(lp l s0 s1)))))))
|
||||
|
||||
(define (intset->intmap f set)
|
||||
(persistent-intmap
|
||||
(intset-fold (lambda (label preds)
|
||||
(intmap-add! preds label (f label)))
|
||||
set empty-intmap)))
|
||||
|
||||
(define (worklist-fold f in out)
|
||||
(if (eq? in empty-intset)
|
||||
out
|
||||
(call-with-values (lambda () (f in out))
|
||||
(lambda (in out)
|
||||
(worklist-fold f in out)))))
|
||||
|
||||
(define (worklist-fold2 f in out0 out1)
|
||||
(if (eq? in empty-intset)
|
||||
(values out0 out1)
|
||||
(call-with-values (lambda () (f in out0 out1))
|
||||
(lambda (in out0 out1)
|
||||
(worklist-fold2 f in out0 out1)))))
|
||||
|
||||
(define (fixpoint f x)
|
||||
(let ((x* (f x)))
|
||||
(if (eq? x x*) x* (f x*))))
|
||||
|
||||
(define (compute-function-body conts kfun)
|
||||
(persistent-intset
|
||||
(let visit-cont ((label kfun) (labels empty-intset))
|
||||
(cond
|
||||
((intset-ref labels label) labels)
|
||||
(else
|
||||
(let ((labels (intset-add! labels label)))
|
||||
(match (intmap-ref conts label)
|
||||
(($ $kreceive arity k) (visit-cont k labels))
|
||||
(($ $kfun src meta self ktail kclause)
|
||||
(let ((labels (visit-cont ktail labels)))
|
||||
(if kclause
|
||||
(visit-cont kclause labels)
|
||||
labels)))
|
||||
(($ $ktail) labels)
|
||||
(($ $kclause arity kbody kalt)
|
||||
(if kalt
|
||||
(visit-cont kalt (visit-cont kbody labels))
|
||||
(visit-cont kbody labels)))
|
||||
(($ $kargs names syms ($ $continue k src exp))
|
||||
(visit-cont k (match exp
|
||||
(($ $branch k)
|
||||
(visit-cont k labels))
|
||||
(($ $callk k)
|
||||
(visit-cont k labels))
|
||||
(($ $prompt escape? tag k)
|
||||
(visit-cont k labels))
|
||||
(_ labels)))))))))))
|
||||
|
||||
(define* (compute-predecessors conts kfun #:key
|
||||
(labels (compute-function-body conts kfun)))
|
||||
(define (meet cdr car)
|
||||
(cons car cdr))
|
||||
(define (add-preds label preds)
|
||||
(define (add-pred k preds)
|
||||
(intmap-add! preds k label meet))
|
||||
(match (intmap-ref conts label)
|
||||
(($ $kreceive arity k)
|
||||
(add-pred k preds))
|
||||
(($ $kfun src meta self ktail kclause)
|
||||
(add-pred ktail (if kclause (add-pred kclause preds) preds)))
|
||||
(($ $ktail)
|
||||
preds)
|
||||
(($ $kclause arity kbody kalt)
|
||||
(add-pred kbody (if kalt (add-pred kalt preds) preds)))
|
||||
(($ $kargs names syms ($ $continue k src exp))
|
||||
(add-pred k
|
||||
(match exp
|
||||
(($ $branch k) (add-pred k preds))
|
||||
(($ $prompt _ _ k) (add-pred k preds))
|
||||
(_ preds))))))
|
||||
(persistent-intmap
|
||||
(intset-fold add-preds labels
|
||||
(intset->intmap (lambda (label) '()) labels))))
|
||||
|
||||
;; Precondition: For each function in CONTS, the continuation names are
|
||||
;; topologically sorted.
|
||||
(define (compute-idoms conts kfun)
|
||||
;; This is the iterative O(n^2) fixpoint algorithm, originally from
|
||||
;; Allen and Cocke ("Graph-theoretic constructs for program flow
|
||||
;; analysis", 1972). See the discussion in Cooper, Harvey, and
|
||||
;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
|
||||
(let ((preds-map (compute-predecessors conts kfun)))
|
||||
(define (compute-idom idoms preds)
|
||||
(match preds
|
||||
(() -1)
|
||||
((pred) pred) ; Shortcut.
|
||||
((pred . preds)
|
||||
(define (common-idom d0 d1)
|
||||
;; We exploit the fact that a reverse post-order is a
|
||||
;; topological sort, and so the idom of a node is always
|
||||
;; numerically less than the node itself.
|
||||
(let lp ((d0 d0) (d1 d1))
|
||||
(cond
|
||||
;; d0 or d1 can be false on the first iteration.
|
||||
((not d0) d1)
|
||||
((not d1) d0)
|
||||
((= d0 d1) d0)
|
||||
((< d0 d1) (lp d0 (intmap-ref idoms d1)))
|
||||
(else (lp (intmap-ref idoms d0) d1)))))
|
||||
(fold1 common-idom preds pred))))
|
||||
(define (adjoin-idom label preds idoms)
|
||||
(let ((idom (compute-idom idoms preds)))
|
||||
;; Don't use intmap-add! here.
|
||||
(intmap-add idoms label idom (lambda (old new) new))))
|
||||
(fixpoint (lambda (idoms)
|
||||
(intmap-fold adjoin-idom preds-map idoms))
|
||||
empty-intmap)))
|
||||
|
||||
;; Compute a vector containing, for each node, a list of the nodes that
|
||||
;; it immediately dominates. These are the "D" edges in the DJ tree.
|
||||
(define (compute-dom-edges idoms)
|
||||
(define (snoc cdr car) (cons car cdr))
|
||||
(intmap-fold (lambda (label idom doms)
|
||||
(let ((doms (intmap-add! doms label '())))
|
||||
(cond
|
||||
((< idom 0) doms) ;; No edge to entry.
|
||||
(else (intmap-add! doms idom label snoc)))))
|
||||
idoms
|
||||
empty-intmap))
|
||||
Loading…
Add table
Add a link
Reference in a new issue