????
Your IP : 3.133.127.132
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013-2015,2017-2018,2020,2021 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 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 cps)
#: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 $branch $switch $prompt $throw
;; Expressions.
$const $prim $fun $rec $const-fun $code
$call $callk $primcall $values
;; 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 kentry)
(define-cps-type $ktail)
(define-cps-type $kclause arity kbody kalternate)
;; Terms.
(define-cps-type $continue k src exp)
(define-cps-type $branch kf kt src op param args)
(define-cps-type $switch kf kt* src arg)
(define-cps-type $prompt k kh src escape? tag)
(define-cps-type $throw src op param args)
;; 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 $const-fun label) ; First-order.
(define-cps-type $code label) ; First-order.
(define-cps-type $call proc args)
(define-cps-type $callk k proc args) ; First-order.
(define-cps-type $primcall name param args)
(define-cps-type $values args)
(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 kentry))
(make-$kfun src meta self ktail kentry))
((_ ($ktail))
(make-$ktail))
((_ ($kclause arity kbody kalternate))
(make-$kclause (build-arity arity) kbody kalternate))))
(define-syntax build-term
(syntax-rules (unquote $continue $branch $switch $prompt $throw)
((_ (unquote exp))
exp)
((_ ($continue k src exp))
(make-$continue k src (build-exp exp)))
((_ ($branch kf kt src op param (unquote args)))
(make-$branch kf kt src op param args))
((_ ($branch kf kt src op param (arg ...)))
(make-$branch kf kt src op param (list arg ...)))
((_ ($branch kf kt src op param args))
(make-$branch kf kt src op param args))
((_ ($switch kf kt* src arg))
(make-$switch kf kt* src arg))
((_ ($prompt k kh src escape? tag))
(make-$prompt k kh src escape? tag))
((_ ($throw src op param (unquote args)))
(make-$throw src op param args))
((_ ($throw src op param (arg ...)))
(make-$throw src op param (list arg ...)))
((_ ($throw src op param args))
(make-$throw src op param args))))
(define-syntax build-exp
(syntax-rules (unquote
$const $prim $fun $rec $const-fun $code
$call $callk $primcall $values)
((_ (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))
((_ ($const-fun k)) (make-$const-fun k))
((_ ($code k)) (make-$code k))
((_ ($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 param (unquote args))) (make-$primcall name param args))
((_ ($primcall name param (arg ...))) (make-$primcall name param (list arg ...)))
((_ ($primcall name param args)) (make-$primcall name param args))
((_ ($values (unquote args))) (make-$values args))
((_ ($values (arg ...))) (make-$values (list arg ...)))
((_ ($values args)) (make-$values args))))
(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 meta self ktail kentry)
(build-cont ($kfun (src exp) meta self ktail kentry)))
(('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)))
;; Terms.
(('continue k exp)
(build-term ($continue k (src exp) ,(parse-cps exp))))
(('branch kf kt op param arg ...)
(build-term ($branch kf kt (src exp) op param arg)))
(('switch kf (kt* ...) arg)
(build-term ($switch kf kt* (src exp) arg)))
(('prompt k kh escape? tag)
(build-term ($prompt k kh (src exp) escape? tag)))
(('throw op param arg ...)
(build-term ($throw (src exp) op param arg)))
;; Expressions.
(('unspecified)
(build-exp ($const *unspecified*)))
(('const exp)
(build-exp ($const exp)))
(('prim name)
(build-exp ($prim name)))
(('fun kbody)
(build-exp ($fun kbody)))
(('const-fun k)
(build-exp ($const-fun k)))
(('code k)
(build-exp ($code k)))
(('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 param arg ...)
(build-exp ($primcall name param arg)))
(('values arg ...)
(build-exp ($values arg)))
(_
(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 kentry)
`(kfun ,meta ,self ,ktail ,kentry))
(($ $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) '())))
;; Terms.
(($ $continue k src exp)
`(continue ,k ,(unparse-cps exp)))
(($ $branch kf kt src op param args)
`(branch ,kf ,kt ,op ,param ,@args))
(($ $switch kf kt* src arg)
`(switch ,kf ,kt* ,arg))
(($ $prompt k kh src escape? tag)
`(prompt ,k ,kh ,escape? ,tag))
(($ $throw src op param args)
`(throw ,op ,param ,@args))
;; Expressions.
(($ $const val)
(if (unspecified? val)
'(unspecified)
`(const ,val)))
(($ $prim name)
`(prim ,name))
(($ $fun kbody)
`(fun ,kbody))
(($ $const-fun k)
`(const-fun ,k))
(($ $code k)
`(code ,k))
(($ $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 param args)
`(primcall ,name ,param ,@args))
(($ $values args)
`(values ,@args))
(_
(error "unexpected cps" exp))))