[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 12/13: Remove CPS1 language
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 12/13: Remove CPS1 language |
|
Date: |
Wed, 22 Jul 2015 15:32:30 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 0d4c9377222ebb45c673b413c0a1f7abd993f8ed
Author: Andy Wingo <address@hidden>
Date: Wed Jul 22 17:15:06 2015 +0200
Remove CPS1 language
* module/language/cps.scm:
* module/language/cps/compile-bytecode.scm:
* module/language/cps/dfg.scm:
* module/language/cps/renumber.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/spec.scm:
* module/language/cps/verify.scm:
* module/language/cps2/compile-cps.scm: Delete.
* module/Makefile.am: Remove deleted files.
---
module/Makefile.am | 10 +-
module/language/cps.scm | 620 --------------------
module/language/cps/compile-bytecode.scm | 453 ---------------
module/language/cps/dfg.scm | 904 ------------------------------
module/language/cps/renumber.scm | 343 -----------
module/language/cps/slot-allocation.scm | 689 -----------------------
module/language/cps/spec.scm | 37 --
module/language/cps/verify.scm | 195 -------
module/language/cps2/compile-cps.scm | 129 -----
9 files changed, 1 insertions(+), 3379 deletions(-)
diff --git a/module/Makefile.am b/module/Makefile.am
index 801f466..c53f9e4 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -122,20 +122,12 @@ TREE_IL_LANG_SOURCES =
\
language/tree-il/spec.scm
CPS_LANG_SOURCES = \
- language/cps.scm \
- language/cps/compile-bytecode.scm \
- language/cps/dfg.scm \
- language/cps/primitives.scm \
- language/cps/renumber.scm \
- language/cps/slot-allocation.scm \
- language/cps/spec.scm \
- language/cps/verify.scm
+ language/cps/primitives.scm
CPS2_LANG_SOURCES = \
language/cps2.scm \
language/cps2/closure-conversion.scm \
language/cps2/compile-bytecode.scm \
- language/cps2/compile-cps.scm \
language/cps2/constructors.scm \
language/cps2/contification.scm \
language/cps2/cse.scm \
diff --git a/module/language/cps.scm b/module/language/cps.scm
deleted file mode 100644
index befa20f..0000000
--- a/module/language/cps.scm
+++ /dev/null
@@ -1,620 +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 is the continuation-passing style (CPS) intermediate language
-;;; (IL) for Guile.
-;;;
-;;; There are two kinds of terms in CPS: terms that bind continuations,
-;;; and terms that call continuations.
-;;;
-;;; $letk binds a set of mutually recursive continuations, each one an
-;;; instance of $cont. A $cont declares the name of a continuation, and
-;;; then contains as a subterm the particular continuation instance:
-;;; $kargs for continuations that bind values, $ktail for the tail
-;;; continuation, etc.
-;;;
-;;; $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
at which
-;;;
-;;; Additionally there is $letrec, a term that binds mutually recursive
-;;; functions. The contification pass will turn $letrec into $letk if
-;;; it can do so. Otherwise, the closure conversion pass will desugar
-;;; $letrec into an equivalent sequence of make-closure primcalls and
-;;; subsequent initializations of the captured variables of the
-;;; closures. You can think of $letrec as pertaining to "high CPS",
-;;; whereas later passes will only see "low CPS", which does not have
-;;; $letrec.
-;;;
-;;; 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!
-;;;
-;;; There are some Guile-specific quirks as well:
-;;;
-;;; - $kreceive represents a continuation that receives multiple values,
-;;; but which truncates them to some number of required values,
-;;; possibly with a rest list.
-;;;
-;;; - $kfun labels an entry point for a $fun (a function), and
-;;; contains a $ktail representing the formal argument which is the
-;;; function's continuation.
-;;;
-;;; - $kfun also contain a $kclause continuation, corresponding to
-;;; the first case-lambda clause of the function. $kclause actually
-;;; contains the clause body, and the subsequent clause (if any).
-;;; This is because the $kclause logically matches or doesn't match
-;;; a given set of actual arguments against a formal arity, then
-;;; proceeds to a "body" continuation (which is a $kargs).
-;;;
-;;; That's to say that a $fun can be matched like this:
-;;;
-;;; (match f
-;;; (($ $fun
-;;; ($ $cont kfun
-;;; ($ $kfun src meta self ($ $cont ktail ($ $ktail))
-;;; ($ $kclause arity
-;;; ($ $cont kbody ($ $kargs names syms body))
-;;; alternate))))
-;;; #t))
-;;;
-;;; A $continue to ktail is in tail position. $kfun, $kclause,
-;;; and $ktail will never be seen elsewhere in a CPS term.
-;;;
-;;; - $prompt continues to the body of the prompt, having pushed on a
-;;; prompt whose handler will continue at its "handler"
-;;; continuation. The continuation of the prompt is responsible for
-;;; popping the prompt.
-;;;
-;;; In summary:
-;;;
-;;; - $letk, $letrec, and $continue are terms.
-;;;
-;;; - $cont is a continuation, containing a continuation body ($kargs,
-;;; $ktail, etc).
-;;;
-;;; - $continue terms contain an expression ($call, $const, $fun,
-;;; etc).
-;;;
-;;; 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-1) #:select (fold))
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-9 gnu)
- #:use-module (srfi srfi-11)
- #:export (;; Helper.
- $arity
- make-$arity
-
- ;; Terms.
- $letk $continue
-
- ;; Continuations.
- $cont
-
- ;; Continuation bodies.
- $kreceive $kargs $kfun $ktail $kclause
-
- ;; Expressions.
- $const $prim $fun $rec $closure $branch
- $call $callk $primcall $values $prompt
-
- ;; First-order CPS root.
- $program
-
- ;; Fresh names.
- label-counter var-counter
- fresh-label fresh-var
- with-fresh-name-state compute-max-label-and-var
- let-fresh
-
- ;; Building macros.
- build-cps-term build-cps-cont build-cps-exp
- rewrite-cps-term rewrite-cps-cont rewrite-cps-exp
-
- ;; Misc.
- parse-cps unparse-cps
- make-global-cont-folder make-local-cont-folder
- fold-conts fold-local-conts
- visit-cont-successors))
-
-;; 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?)
-
-;; Terms.
-(define-cps-type $letk conts body)
-(define-cps-type $continue k src exp)
-
-;; Continuations
-(define-cps-type $cont k cont)
-(define-cps-type $kreceive arity k)
-(define-cps-type $kargs names syms body)
-(define-cps-type $kfun src meta self tail clause)
-(define-cps-type $ktail)
-(define-cps-type $kclause arity cont alternate)
-
-;; 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 k 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)
-
-;; The root of a higher-order CPS term is $cont containing a $kfun. The
-;; root of a first-order CPS term is a $program.
-(define-cps-type $program funs)
-
-(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-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-body
- (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-cps-term body)))
- ((_ ($kargs (name ...) (sym ...) body))
- (make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
- ((_ ($kargs names syms body))
- (make-$kargs names syms (build-cps-term body)))
- ((_ ($kfun src meta self tail clause))
- (make-$kfun src meta self (build-cps-cont tail) (build-cps-cont clause)))
- ((_ ($ktail))
- (make-$ktail))
- ((_ ($kclause arity cont alternate))
- (make-$kclause (build-arity arity) (build-cps-cont cont)
- (build-cps-cont alternate)))))
-
-(define-syntax build-cps-cont
- (syntax-rules (unquote)
- ((_ (unquote exp)) exp)
- ((_ (k cont)) (make-$cont k (build-cont-body cont)))))
-
-(define-syntax build-cps-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 body)) (make-$fun (build-cps-cont body)))
- ((_ ($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 k exp)) (make-$branch k (build-cps-exp exp)))
- ((_ ($prompt escape? tag handler))
- (make-$prompt escape? tag handler))))
-
-(define-syntax build-cps-term
- (syntax-rules (unquote $letk $letk* $letconst $program $continue)
- ((_ (unquote exp))
- exp)
- ((_ ($letk (unquote conts) body))
- (make-$letk conts (build-cps-term body)))
- ((_ ($letk (cont ...) body))
- (make-$letk (list (build-cps-cont cont) ...)
- (build-cps-term body)))
- ((_ ($letk* () body))
- (build-cps-term body))
- ((_ ($letk* (cont conts ...) body))
- (build-cps-term ($letk (cont) ($letk* (conts ...) body))))
- ((_ ($letconst () body))
- (build-cps-term body))
- ((_ ($letconst ((name sym val) tail ...) body))
- (let-fresh (kconst) ()
- (build-cps-term
- ($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body))))
- ($continue kconst (let ((props (source-properties val)))
- (and (pair? props) props))
- ($const val))))))
- ((_ ($program (unquote conts)))
- (make-$program conts))
- ((_ ($program (cont ...)))
- (make-$program (list (build-cps-cont cont) ...)))
- ((_ ($program conts))
- (make-$program conts))
- ((_ ($continue k src exp))
- (make-$continue k src (build-cps-exp exp)))))
-
-(define-syntax-rule (rewrite-cps-term x (pat body) ...)
- (match x
- (pat (build-cps-term body)) ...))
-(define-syntax-rule (rewrite-cps-cont x (pat body) ...)
- (match x
- (pat (build-cps-cont body)) ...))
-(define-syntax-rule (rewrite-cps-exp x (pat body) ...)
- (match x
- (pat (build-cps-exp body)) ...))
-
-(define (parse-cps exp)
- (define (src exp)
- (let ((props (source-properties exp)))
- (and (pair? props) props)))
- (match exp
- ;; Continuations.
- (('letconst k (name sym c) body)
- (build-cps-term
- ($letk ((k ($kargs (name) (sym)
- ,(parse-cps body))))
- ($continue k (src exp) ($const c)))))
- (('let k (name sym val) body)
- (build-cps-term
- ($letk ((k ($kargs (name) (sym)
- ,(parse-cps body))))
- ,(parse-cps val))))
- (('letk (cont ...) body)
- (build-cps-term
- ($letk ,(map parse-cps cont) ,(parse-cps body))))
- (('k sym body)
- (build-cps-cont
- (sym ,(parse-cps body))))
- (('kreceive req rest k)
- (build-cont-body ($kreceive req rest k)))
- (('kargs names syms body)
- (build-cont-body ($kargs names syms ,(parse-cps body))))
- (('kfun src meta self tail clause)
- (build-cont-body
- ($kfun (src exp) meta self ,(parse-cps tail)
- ,(and=> clause parse-cps))))
- (('ktail)
- (build-cont-body
- ($ktail)))
- (('kclause (req opt rest kw allow-other-keys?) body)
- (build-cont-body
- ($kclause (req opt rest kw allow-other-keys?)
- ,(parse-cps body)
- ,#f)))
- (('kclause (req opt rest kw allow-other-keys?) body alternate)
- (build-cont-body
- ($kclause (req opt rest kw allow-other-keys?)
- ,(parse-cps body)
- ,(parse-cps alternate))))
- (('kseq body)
- (build-cont-body ($kargs () () ,(parse-cps body))))
-
- ;; Calls.
- (('continue k exp)
- (build-cps-term ($continue k (src exp) ,(parse-cps exp))))
- (('const exp)
- (build-cps-exp ($const exp)))
- (('prim name)
- (build-cps-exp ($prim name)))
- (('fun body)
- (build-cps-exp ($fun ,(parse-cps body))))
- (('closure k nfree)
- (build-cps-exp ($closure k nfree)))
- (('rec (name sym fun) ...)
- (build-cps-exp ($rec name sym (map parse-cps fun))))
- (('program (cont ...))
- (build-cps-term ($program ,(map parse-cps cont))))
- (('call proc arg ...)
- (build-cps-exp ($call proc arg)))
- (('callk k proc arg ...)
- (build-cps-exp ($callk k proc arg)))
- (('primcall name arg ...)
- (build-cps-exp ($primcall name arg)))
- (('branch k exp)
- (build-cps-exp ($branch k ,(parse-cps exp))))
- (('values arg ...)
- (build-cps-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.
- (($ $letk (($ $cont k ($ $kargs (name) (sym) body)))
- ($ $continue k src ($ $const c)))
- `(letconst ,k (,name ,sym ,c)
- ,(unparse-cps body)))
- (($ $letk (($ $cont k ($ $kargs (name) (sym) body))) val)
- `(let ,k (,name ,sym ,(unparse-cps val))
- ,(unparse-cps body)))
- (($ $letk conts body)
- `(letk ,(map unparse-cps conts) ,(unparse-cps body)))
- (($ $cont sym body)
- `(k ,sym ,(unparse-cps body)))
- (($ $kreceive ($ $arity req () rest '() #f) k)
- `(kreceive ,req ,rest ,k))
- (($ $kargs () () body)
- `(kseq ,(unparse-cps body)))
- (($ $kargs names syms body)
- `(kargs ,names ,syms ,(unparse-cps body)))
- (($ $kfun src meta self tail clause)
- `(kfun ,meta ,self ,(unparse-cps tail) ,(unparse-cps clause)))
- (($ $ktail)
- `(ktail))
- (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alternate)
- `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)
- . ,(if alternate (list (unparse-cps alternate)) '())))
-
- ;; Calls.
- (($ $continue k src exp)
- `(continue ,k ,(unparse-cps exp)))
- (($ $const val)
- `(const ,val))
- (($ $prim name)
- `(prim ,name))
- (($ $fun body)
- `(fun ,(unparse-cps body)))
- (($ $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)))
- (($ $program conts)
- `(program ,(map unparse-cps conts)))
- (($ $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))))
-
-(define-syntax-rule (make-global-cont-folder seed ...)
- (lambda (proc cont seed ...)
- (define (cont-folder cont seed ...)
- (match cont
- (($ $cont k cont)
- (let-values (((seed ...) (proc k cont seed ...)))
- (match cont
- (($ $kargs names syms body)
- (term-folder body seed ...))
-
- (($ $kfun src meta self tail clause)
- (let-values (((seed ...) (cont-folder tail seed ...)))
- (if clause
- (cont-folder clause seed ...)
- (values seed ...))))
-
- (($ $kclause arity body alternate)
- (let-values (((seed ...) (cont-folder body seed ...)))
- (if alternate
- (cont-folder alternate seed ...)
- (values seed ...))))
-
- (_ (values seed ...)))))))
-
- (define (fun-folder fun seed ...)
- (match fun
- (($ $fun body)
- (cont-folder body seed ...))))
-
- (define (term-folder term seed ...)
- (match term
- (($ $letk conts body)
- (let-values (((seed ...) (term-folder body seed ...)))
- (let lp ((conts conts) (seed seed) ...)
- (if (null? conts)
- (values seed ...)
- (let-values (((seed ...) (cont-folder (car conts) seed ...)))
- (lp (cdr conts) seed ...))))))
-
- (($ $continue k src exp)
- (match exp
- (($ $fun) (fun-folder exp seed ...))
- (($ $rec names syms funs)
- (let lp ((funs funs) (seed seed) ...)
- (if (null? funs)
- (values seed ...)
- (let-values (((seed ...) (fun-folder (car funs) seed ...)))
- (lp (cdr funs) seed ...)))))
- (_ (values seed ...))))))
-
- (cont-folder cont seed ...)))
-
-(define-syntax-rule (make-local-cont-folder seed ...)
- (lambda (proc cont seed ...)
- (define (cont-folder cont seed ...)
- (match cont
- (($ $cont k (and cont ($ $kargs names syms body)))
- (let-values (((seed ...) (proc k cont seed ...)))
- (term-folder body seed ...)))
- (($ $cont k cont)
- (proc k cont seed ...))))
- (define (term-folder term seed ...)
- (match term
- (($ $letk conts body)
- (let-values (((seed ...) (term-folder body seed ...)))
- (let lp ((conts conts) (seed seed) ...)
- (match conts
- (() (values seed ...))
- ((cont) (cont-folder cont seed ...))
- ((cont . conts)
- (let-values (((seed ...) (cont-folder cont seed ...)))
- (lp conts seed ...)))))))
- (_ (values seed ...))))
- (define (clause-folder clause seed ...)
- (match clause
- (($ $cont k (and cont ($ $kclause arity body alternate)))
- (let-values (((seed ...) (proc k cont seed ...)))
- (if alternate
- (let-values (((seed ...) (cont-folder body seed ...)))
- (clause-folder alternate seed ...))
- (cont-folder body seed ...))))))
- (match cont
- (($ $cont k (and cont ($ $kfun src meta self tail clause)))
- (let*-values (((seed ...) (proc k cont seed ...))
- ((seed ...) (if clause
- (clause-folder clause seed ...)
- (values seed ...))))
- (cont-folder tail seed ...))))))
-
-(define (compute-max-label-and-var fun)
- (match fun
- (($ $cont)
- ((make-global-cont-folder max-label max-var)
- (lambda (label cont max-label max-var)
- (values (max label max-label)
- (match cont
- (($ $kargs names vars body)
- (fold max max-var vars))
- (($ $kfun src meta self)
- (max self max-var))
- (_ max-var))))
- fun -1 -1))
- (($ $program conts)
- (define (fold/2 proc in s0 s1)
- (if (null? in)
- (values s0 s1)
- (let-values (((s0 s1) (proc (car in) s0 s1)))
- (fold/2 proc (cdr in) s0 s1))))
- (let lp ((conts conts) (max-label -1) (max-var -1))
- (if (null? conts)
- (values max-label max-var)
- (call-with-values (lambda ()
- ((make-local-cont-folder max-label max-var)
- (lambda (label cont max-label max-var)
- (values (max label max-label)
- (match cont
- (($ $kargs names vars body)
- (fold max max-var vars))
- (($ $kfun src meta self)
- (max self max-var))
- (_ max-var))))
- (car conts) max-label max-var))
- (lambda (max-label max-var)
- (lp (cdr conts) max-label max-var))))))))
-
-(define (fold-conts proc seed fun)
- ((make-global-cont-folder seed) proc fun seed))
-
-(define (fold-local-conts proc seed fun)
- ((make-local-cont-folder seed) proc fun seed))
-
-(define (visit-cont-successors proc cont)
- (match cont
- (($ $kargs names syms body)
- (let lp ((body body))
- (match body
- (($ $letk conts body) (lp body))
- (($ $continue k src exp)
- (match exp
- (($ $prompt escape? tag handler) (proc k handler))
- (($ $branch kt) (proc k kt))
- (_ (proc k)))))))
-
- (($ $kreceive arity k) (proc k))
-
- (($ $kclause arity ($ $cont kbody) #f) (proc kbody))
-
- (($ $kclause arity ($ $cont kbody) ($ $cont kalt)) (proc kbody kalt))
-
- (($ $kfun src meta self tail ($ $cont clause)) (proc clause))
-
- (($ $kfun src meta self tail #f) (proc))
-
- (($ $ktail) (proc))))
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
deleted file mode 100644
index c92c15d..0000000
--- a/module/language/cps/compile-bytecode.scm
+++ /dev/null
@@ -1,453 +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:
-;;;
-;;; Compiling CPS to bytecode. The result is in the bytecode language,
-;;; which happens to be an ELF image as a bytecode.
-;;;
-;;; Code:
-
-(define-module (language cps compile-bytecode)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-1)
- #:use-module (language cps)
- #:use-module (language cps dfg)
- #:use-module (language cps primitives)
- #:use-module (language cps renumber)
- #:use-module (language cps slot-allocation)
- #:use-module (system vm assembler)
- #:export (compile-bytecode))
-
-(define (kw-arg-ref args kw default)
- (match (memq kw args)
- ((_ val . _) val)
- (_ default)))
-
-(define (compile-fun f asm)
- (let* ((dfg (compute-dfg f #:global? #f))
- (allocation (allocate-slots f dfg)))
- (define (maybe-slot sym)
- (lookup-maybe-slot sym allocation))
-
- (define (slot sym)
- (lookup-slot sym allocation))
-
- (define (constant sym)
- (lookup-constant-value sym allocation))
-
- (define (maybe-mov dst src)
- (unless (= dst src)
- (emit-mov asm dst src)))
-
- (define (maybe-load-constant slot src)
- (call-with-values (lambda ()
- (lookup-maybe-constant-value src allocation))
- (lambda (has-const? val)
- (and has-const?
- (begin
- (emit-load-constant asm slot val)
- #t)))))
-
- (define (compile-entry)
- (let ((label (dfg-min-label dfg)))
- (match (lookup-cont label dfg)
- (($ $kfun src meta self tail clause)
- (when src
- (emit-source asm src))
- (emit-begin-program asm label meta)
- (compile-clause (1+ label))
- (emit-end-program asm)))))
-
- (define (compile-clause label)
- (match (lookup-cont label dfg)
- (($ $kclause ($ $arity req opt rest kw allow-other-keys?)
- body alternate)
- (let* ((kw-indices (map (match-lambda
- ((key name sym)
- (cons key (lookup-slot sym allocation))))
- kw))
- (nlocals (lookup-nlocals label allocation)))
- (emit-label asm label)
- (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
- nlocals
- (match alternate (#f #f) (($ $cont alt) alt)))
- (let ((next (compile-body (1+ label) nlocals)))
- (emit-end-arity asm)
- (match alternate
- (($ $cont alt)
- (unless (eq? next alt)
- (error "unexpected k" alt))
- (compile-clause next))
- (#f
- (unless (= next (+ (dfg-min-label dfg) (dfg-label-count dfg)))
- (error "unexpected end of clauses")))))))))
-
- (define (compile-body label nlocals)
- (let compile-cont ((label label))
- (if (eq? label (+ (dfg-min-label dfg) (dfg-label-count dfg)))
- label
- (match (lookup-cont label dfg)
- (($ $kclause) label)
- (($ $kargs names vars term)
- (emit-label asm label)
- (for-each (lambda (name var)
- (let ((slot (maybe-slot var)))
- (when slot
- (emit-definition asm name slot))))
- names vars)
- (let find-exp ((term term))
- (match term
- (($ $letk conts term)
- (find-exp term))
- (($ $continue k src exp)
- (when src
- (emit-source asm src))
- (compile-expression label k exp nlocals)
- (compile-cont (1+ label))))))
- (_
- (emit-label asm label)
- (compile-cont (1+ label)))))))
-
- (define (compile-expression label k exp nlocals)
- (let* ((fallthrough? (= k (1+ label))))
- (define (maybe-emit-jump)
- (unless fallthrough?
- (emit-br asm k)))
- (match (lookup-cont k dfg)
- (($ $ktail)
- (compile-tail label exp))
- (($ $kargs (name) (sym))
- (let ((dst (maybe-slot sym)))
- (when dst
- (compile-value label exp dst nlocals)))
- (maybe-emit-jump))
- (($ $kargs () ())
- (match exp
- (($ $branch kt exp)
- (compile-test label exp kt k (1+ label)))
- (_
- (compile-effect label exp k nlocals)
- (maybe-emit-jump))))
- (($ $kargs names syms)
- (compile-values label exp syms)
- (maybe-emit-jump))
- (($ $kreceive ($ $arity req () rest () #f) kargs)
- (compile-trunc label k exp (length req)
- (and rest
- (match (lookup-cont kargs dfg)
- (($ $kargs names (_ ... rest)) rest)))
- nlocals)
- (unless (and fallthrough? (= kargs (1+ k)))
- (emit-br asm kargs))))))
-
- (define (compile-tail label exp)
- ;; There are only three kinds of expressions in tail position:
- ;; tail calls, multiple-value returns, and single-value returns.
- (match exp
- (($ $call proc args)
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves label allocation))
- (let ((tail-slots (cdr (iota (1+ (length args))))))
- (for-each maybe-load-constant tail-slots args))
- (emit-tail-call asm (1+ (length args))))
- (($ $callk k proc args)
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves label allocation))
- (let ((tail-slots (cdr (iota (1+ (length args))))))
- (for-each maybe-load-constant tail-slots args))
- (emit-tail-call-label asm (1+ (length args)) k))
- (($ $values ())
- (emit-reset-frame asm 1)
- (emit-return-values asm))
- (($ $values (arg))
- (if (maybe-slot arg)
- (emit-return asm (slot arg))
- (begin
- (emit-load-constant asm 1 (constant arg))
- (emit-return asm 1))))
- (($ $values args)
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves label allocation))
- (let ((tail-slots (cdr (iota (1+ (length args))))))
- (for-each maybe-load-constant tail-slots args))
- (emit-reset-frame asm (1+ (length args)))
- (emit-return-values asm))
- (($ $primcall 'return (arg))
- (emit-return asm (slot arg)))))
-
- (define (compile-value label exp dst nlocals)
- (match exp
- (($ $values (arg))
- (or (maybe-load-constant dst arg)
- (maybe-mov dst (slot arg))))
- (($ $const exp)
- (emit-load-constant asm dst exp))
- (($ $closure k 0)
- (emit-load-static-procedure asm dst k))
- (($ $closure k nfree)
- (emit-make-closure asm dst k nfree))
- (($ $primcall 'current-module)
- (emit-current-module asm dst))
- (($ $primcall 'cached-toplevel-box (scope name bound?))
- (emit-cached-toplevel-box asm dst (constant scope) (constant name)
- (constant bound?)))
- (($ $primcall 'cached-module-box (mod name public? bound?))
- (emit-cached-module-box asm dst (constant mod) (constant name)
- (constant public?) (constant bound?)))
- (($ $primcall 'resolve (name bound?))
- (emit-resolve asm dst (constant bound?) (slot name)))
- (($ $primcall 'free-ref (closure idx))
- (emit-free-ref asm dst (slot closure) (constant idx)))
- (($ $primcall 'vector-ref (vector index))
- (emit-vector-ref asm dst (slot vector) (slot index)))
- (($ $primcall 'make-vector (length init))
- (emit-make-vector asm dst (slot length) (slot init)))
- (($ $primcall 'make-vector/immediate (length init))
- (emit-make-vector/immediate asm dst (constant length) (slot init)))
- (($ $primcall 'vector-ref/immediate (vector index))
- (emit-vector-ref/immediate asm dst (slot vector) (constant index)))
- (($ $primcall 'allocate-struct (vtable nfields))
- (emit-allocate-struct asm dst (slot vtable) (slot nfields)))
- (($ $primcall 'allocate-struct/immediate (vtable nfields))
- (emit-allocate-struct/immediate asm dst (slot vtable) (constant
nfields)))
- (($ $primcall 'struct-ref (struct n))
- (emit-struct-ref asm dst (slot struct) (slot n)))
- (($ $primcall 'struct-ref/immediate (struct n))
- (emit-struct-ref/immediate asm dst (slot struct) (constant n)))
- (($ $primcall 'builtin-ref (name))
- (emit-builtin-ref asm dst (constant name)))
- (($ $primcall 'bv-u8-ref (bv idx))
- (emit-bv-u8-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-s8-ref (bv idx))
- (emit-bv-s8-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-u16-ref (bv idx))
- (emit-bv-u16-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-s16-ref (bv idx))
- (emit-bv-s16-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-u32-ref (bv idx val))
- (emit-bv-u32-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-s32-ref (bv idx val))
- (emit-bv-s32-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-u64-ref (bv idx val))
- (emit-bv-u64-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-s64-ref (bv idx val))
- (emit-bv-s64-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-f32-ref (bv idx val))
- (emit-bv-f32-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-f64-ref (bv idx val))
- (emit-bv-f64-ref asm dst (slot bv) (slot idx)))
- (($ $primcall name args)
- ;; FIXME: Inline all the cases.
- (let ((inst (prim-instruction name)))
- (emit-text asm `((,inst ,dst ,@(map slot args))))))))
-
- (define (compile-effect label exp k nlocals)
- (match exp
- (($ $values ()) #f)
- (($ $prompt escape? tag handler)
- (match (lookup-cont handler dfg)
- (($ $kreceive ($ $arity req () rest () #f) khandler-body)
- (let ((receive-args (gensym "handler"))
- (nreq (length req))
- (proc-slot (lookup-call-proc-slot handler allocation)))
- (emit-prompt asm (slot tag) escape? proc-slot receive-args)
- (emit-br asm k)
- (emit-label asm receive-args)
- (unless (and rest (zero? nreq))
- (emit-receive-values asm proc-slot (->bool rest) nreq))
- (when (and rest
- (match (lookup-cont khandler-body dfg)
- (($ $kargs names (_ ... rest))
- (maybe-slot rest))))
- (emit-bind-rest asm (+ proc-slot 1 nreq)))
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves handler allocation))
- (emit-reset-frame asm nlocals)
- (emit-br asm khandler-body)))))
- (($ $primcall 'cache-current-module! (sym scope))
- (emit-cache-current-module! asm (slot sym) (constant scope)))
- (($ $primcall 'free-set! (closure idx value))
- (emit-free-set! asm (slot closure) (slot value) (constant idx)))
- (($ $primcall 'box-set! (box value))
- (emit-box-set! asm (slot box) (slot value)))
- (($ $primcall 'struct-set! (struct index value))
- (emit-struct-set! asm (slot struct) (slot index) (slot value)))
- (($ $primcall 'struct-set!/immediate (struct index value))
- (emit-struct-set!/immediate asm (slot struct) (constant index) (slot
value)))
- (($ $primcall 'vector-set! (vector index value))
- (emit-vector-set! asm (slot vector) (slot index) (slot value)))
- (($ $primcall 'vector-set!/immediate (vector index value))
- (emit-vector-set!/immediate asm (slot vector) (constant index)
- (slot value)))
- (($ $primcall 'set-car! (pair value))
- (emit-set-car! asm (slot pair) (slot value)))
- (($ $primcall 'set-cdr! (pair value))
- (emit-set-cdr! asm (slot pair) (slot value)))
- (($ $primcall 'define! (sym value))
- (emit-define! asm (slot sym) (slot value)))
- (($ $primcall 'push-fluid (fluid val))
- (emit-push-fluid asm (slot fluid) (slot val)))
- (($ $primcall 'pop-fluid ())
- (emit-pop-fluid asm))
- (($ $primcall 'wind (winder unwinder))
- (emit-wind asm (slot winder) (slot unwinder)))
- (($ $primcall 'bv-u8-set! (bv idx val))
- (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-s8-set! (bv idx val))
- (emit-bv-s8-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-u16-set! (bv idx val))
- (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-s16-set! (bv idx val))
- (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-u32-set! (bv idx val))
- (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-s32-set! (bv idx val))
- (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-u64-set! (bv idx val))
- (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-s64-set! (bv idx val))
- (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-f32-set! (bv idx val))
- (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-f64-set! (bv idx val))
- (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'unwind ())
- (emit-unwind asm))))
-
- (define (compile-values label exp syms)
- (match exp
- (($ $values args)
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves label allocation))
- (for-each maybe-load-constant (map slot syms) args))))
-
- (define (compile-test label exp kt kf next-label)
- (define (unary op sym)
- (cond
- ((eq? kt next-label)
- (op asm (slot sym) #t kf))
- (else
- (op asm (slot sym) #f kt)
- (unless (eq? kf next-label)
- (emit-br asm kf)))))
- (define (binary op a b)
- (cond
- ((eq? kt next-label)
- (op asm (slot a) (slot b) #t kf))
- (else
- (op asm (slot a) (slot b) #f kt)
- (unless (eq? kf next-label)
- (emit-br asm kf)))))
- (match exp
- (($ $values (sym))
- (call-with-values (lambda ()
- (lookup-maybe-constant-value sym allocation))
- (lambda (has-const? val)
- (if has-const?
- (if val
- (unless (eq? kt next-label)
- (emit-br asm kt))
- (unless (eq? kf next-label)
- (emit-br asm kf)))
- (unary emit-br-if-true sym)))))
- (($ $primcall 'null? (a)) (unary emit-br-if-null a))
- (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
- (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
- (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
- (($ $primcall 'char? (a)) (unary emit-br-if-char a))
- (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
- (($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
- (($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
- (($ $primcall 'string? (a)) (unary emit-br-if-string a))
- (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
- (($ $primcall 'bitvector? (a)) (unary emit-br-if-bitvector a))
- (($ $primcall 'keyword? (a)) (unary emit-br-if-keyword a))
- ;; Add more TC7 tests here. Keep in sync with
- ;; *branching-primcall-arities* in (language cps primitives) and
- ;; the set of macro-instructions in assembly.scm.
- (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
- (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
- (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
- (($ $primcall '< (a b)) (binary emit-br-if-< a b))
- (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
- (($ $primcall '= (a b)) (binary emit-br-if-= a b))
- (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
- (($ $primcall '> (a b)) (binary emit-br-if-< b a))
- (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))))
-
- (define (compile-trunc label k exp nreq rest-var nlocals)
- (define (do-call proc args emit-call)
- (let* ((proc-slot (lookup-call-proc-slot label allocation))
- (nargs (1+ (length args)))
- (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves label allocation))
- (for-each maybe-load-constant arg-slots (cons proc args))
- (emit-call asm proc-slot nargs)
- (emit-dead-slot-map asm proc-slot
- (lookup-dead-slot-map label allocation))
- (cond
- ((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
- (match (lookup-parallel-moves k allocation)
- ((((? (lambda (src) (= src (1+ proc-slot))) src)
- . dst)) dst)
- (_ #f)))
- ;; The usual case: one required live return value, ignoring
- ;; any additional values.
- => (lambda (dst)
- (emit-receive asm dst proc-slot nlocals)))
- (else
- (unless (and (zero? nreq) rest-var)
- (emit-receive-values asm proc-slot (->bool rest-var) nreq))
- (when (and rest-var (maybe-slot rest-var))
- (emit-bind-rest asm (+ proc-slot 1 nreq)))
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves k allocation))
- (emit-reset-frame asm nlocals)))))
- (match exp
- (($ $call proc args)
- (do-call proc args
- (lambda (asm proc-slot nargs)
- (emit-call asm proc-slot nargs))))
- (($ $callk k proc args)
- (do-call proc args
- (lambda (asm proc-slot nargs)
- (emit-call-label asm proc-slot nargs k))))))
-
- (match f
- (($ $cont k ($ $kfun src meta self tail clause))
- (compile-entry)))))
-
-(define (compile-bytecode exp env opts)
- (let* ((exp (renumber exp))
- (asm (make-assembler)))
- (match exp
- (($ $program funs)
- (for-each (lambda (fun) (compile-fun fun asm))
- funs)))
- (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
- env
- env)))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
deleted file mode 100644
index 22bc159..0000000
--- a/module/language/cps/dfg.scm
+++ /dev/null
@@ -1,904 +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:
-;;;
-;;; Many passes rely on a local or global static analysis of a function.
-;;; This module implements a simple data-flow graph (DFG) analysis,
-;;; tracking the definitions and uses of variables and continuations.
-;;; It also builds a table of continuations and scope links, to be able
-;;; to easily determine if one continuation is in the scope of another,
-;;; and to get to the expression inside a continuation.
-;;;
-;;; Note that the data-flow graph of continuation labels is a
-;;; control-flow graph.
-;;;
-;;; We currently don't expose details of the DFG type outside this
-;;; module, preferring to only expose accessors. That may change in the
-;;; future but it seems to work for now.
-;;;
-;;; Code:
-
-(define-module (language cps dfg)
- #:use-module (ice-9 match)
- #:use-module (ice-9 format)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-26)
- #:use-module (language cps)
- #:use-module (language cps intset)
- #:export (build-cont-table
- lookup-cont
-
- compute-dfg
- dfg-cont-table
- dfg-min-label
- dfg-label-count
- dfg-min-var
- dfg-var-count
- with-fresh-name-state-from-dfg
- lookup-def
- lookup-uses
- lookup-predecessors
- lookup-successors
- lookup-block-scope
- find-call
- call-expression
- find-expression
- find-defining-expression
- find-constant-value
- continuation-bound-in?
- variable-free-in?
- constant-needs-allocation?
- control-point?
- lookup-bound-syms
-
- compute-idoms
- compute-dom-edges
-
- ;; Data flow analysis.
- compute-live-variables
- dfa-k-idx dfa-k-sym dfa-k-count dfa-k-in dfa-k-out
- dfa-var-idx dfa-var-sym dfa-var-count
- print-dfa))
-
-;; These definitions are here because currently we don't do cross-module
-;; inlining. They can be removed once that restriction is gone.
-(define-inlinable (for-each f l)
- (unless (list? l)
- (scm-error 'wrong-type-arg "for-each" "Not a list: ~S" (list l) #f))
- (let for-each1 ((l l))
- (unless (null? l)
- (f (car l))
- (for-each1 (cdr l)))))
-
-(define-inlinable (for-each/2 f l1 l2)
- (unless (= (length l1) (length l2))
- (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
- (list l2) #f))
- (let for-each2 ((l1 l1) (l2 l2))
- (unless (null? l1)
- (f (car l1) (car l2))
- (for-each2 (cdr l1) (cdr l2)))))
-
-(define (build-cont-table fun)
- (let ((max-k (fold-conts (lambda (k cont max-k) (max k max-k))
- -1 fun)))
- (fold-conts (lambda (k cont table)
- (vector-set! table k cont)
- table)
- (make-vector (1+ max-k) #f)
- fun)))
-
-;; Data-flow graph for CPS: both for values and continuations.
-(define-record-type $dfg
- (make-dfg conts preds defs uses scopes scope-levels
- min-label max-label label-count
- min-var max-var var-count)
- dfg?
- ;; vector of label -> $kargs, etc
- (conts dfg-cont-table)
- ;; vector of label -> (pred-label ...)
- (preds dfg-preds)
- ;; vector of var -> def-label
- (defs dfg-defs)
- ;; vector of var -> (use-label ...)
- (uses dfg-uses)
- ;; vector of label -> label
- (scopes dfg-scopes)
- ;; vector of label -> int
- (scope-levels dfg-scope-levels)
-
- (min-label dfg-min-label)
- (max-label dfg-max-label)
- (label-count dfg-label-count)
-
- (min-var dfg-min-var)
- (max-var dfg-max-var)
- (var-count dfg-var-count))
-
-(define-inlinable (vector-push! vec idx val)
- (let ((v vec) (i idx))
- (vector-set! v i (cons val (vector-ref v i)))))
-
-(define (compute-reachable dfg min-label label-count)
- "Compute and return the continuations that may be reached if flow
-reaches a continuation N. Returns a vector of intsets, whose first
-index corresponds to MIN-LABEL, and so on."
- (let (;; Vector of intsets, indicating that continuation N can
- ;; reach a set M...
- (reachable (make-vector label-count #f)))
-
- (define (label->idx label) (- label min-label))
-
- ;; Iterate labels backwards, to converge quickly.
- (let lp ((label (+ min-label label-count)) (changed? #f))
- (cond
- ((= label min-label)
- (if changed?
- (lp (+ min-label label-count) #f)
- reachable))
- (else
- (let* ((label (1- label))
- (idx (label->idx label))
- (old (vector-ref reachable idx))
- (new (fold (lambda (succ set)
- (cond
- ((vector-ref reachable (label->idx succ))
- => (lambda (succ-set)
- (intset-union set succ-set)))
- (else set)))
- (or (vector-ref reachable idx)
- (intset-add empty-intset label))
- (visit-cont-successors list
- (lookup-cont label dfg)))))
- (cond
- ((eq? old new)
- (lp label changed?))
- (else
- (vector-set! reachable idx new)
- (lp label #t)))))))))
-
-(define (find-prompts dfg min-label label-count)
- "Find the prompts in DFG between MIN-LABEL and MIN-LABEL +
-LABEL-COUNT, and return them as a list of PROMPT-LABEL, HANDLER-LABEL
-pairs."
- (let lp ((label min-label) (prompts '()))
- (cond
- ((= label (+ min-label label-count))
- (reverse prompts))
- (else
- (match (lookup-cont label dfg)
- (($ $kargs names syms body)
- (match (find-expression body)
- (($ $prompt escape? tag handler)
- (lp (1+ label) (acons label handler prompts)))
- (_ (lp (1+ label) prompts))))
- (_ (lp (1+ label) prompts)))))))
-
-(define (compute-interval reachable min-label label-count start end)
- "Compute and return the set of continuations that may be reached from
-START, inclusive, but not reached by END, exclusive. Returns an
-intset."
- (intset-subtract (vector-ref reachable (- start min-label))
- (vector-ref reachable (- end min-label))))
-
-(define (find-prompt-bodies dfg min-label label-count)
- "Find all the prompts in DFG from the LABEL-COUNT continuations
-starting at MIN-LABEL, and compute the set of continuations that is
-reachable from the prompt bodies but not from the corresponding handler.
-Returns a list of PROMPT, HANDLER, BODY lists, where the BODY is an
-intset."
- (match (find-prompts dfg min-label label-count)
- (() '())
- (((prompt . handler) ...)
- (let ((reachable (compute-reachable dfg min-label label-count)))
- (map (lambda (prompt handler)
- ;; FIXME: It isn't correct to use all continuations
- ;; reachable from the prompt, because that includes
- ;; continuations outside the prompt body. This point is
- ;; moot if the handler's control flow joins with the the
- ;; body, as is usually but not always the case.
- ;;
- ;; One counter-example is when the handler contifies an
- ;; infinite loop; in that case we compute a too-large
- ;; prompt body. This error is currently innocuous, but we
- ;; should fix it at some point.
- ;;
- ;; The fix is to end the body at the corresponding "pop"
- ;; primcall, if any.
- (let ((body (compute-interval reachable min-label label-count
- prompt handler)))
- (list prompt handler body)))
- prompt handler)))))
-
-(define* (visit-prompt-control-flow dfg min-label label-count f #:key
complete?)
- "For all prompts in DFG in the range [MIN-LABEL, MIN-LABEL +
-LABEL-COUNT), invoke F with arguments PROMPT, HANDLER, and BODY for each
-body continuation in the prompt."
- (define (label->idx label) (- label min-label))
- (define (idx->label idx) (+ idx min-label))
- (for-each
- (match-lambda
- ((prompt handler body)
- (define (out-or-back-edge? label)
- ;; Most uses of visit-prompt-control-flow don't need every body
- ;; continuation, and would be happy getting called only for
- ;; continuations that postdominate the rest of the body. Unless
- ;; you pass #:complete? #t, we only invoke F on continuations
- ;; that can leave the body, or on back-edges in loops.
- ;;
- ;; You would think that looking for the final "pop" primcall
- ;; would be sufficient, but that is incorrect; it's possible for
- ;; a loop in the prompt body to be contified, and that loop need
- ;; not continue to the pop if it never terminates. The pop could
- ;; even be removed by DCE, in that case.
- (or-map (lambda (succ)
- (or (not (intset-ref body succ))
- (<= succ label)))
- (lookup-successors label dfg)))
- (let lp ((label min-label))
- (let ((label (intset-next body label)))
- (when label
- (when (or complete? (out-or-back-edge? label))
- (f prompt handler label))
- (lp (1+ label)))))))
- (find-prompt-bodies dfg min-label label-count)))
-
-(define (analyze-reverse-control-flow fun dfg min-label label-count)
- (define (compute-reverse-control-flow-order ktail dfg)
- (let ((label-map (make-vector label-count #f))
- (next -1))
- (define (label->idx label) (- label min-label))
- (define (idx->label idx) (+ idx min-label))
-
- (let visit ((k ktail))
- ;; Mark this label as visited.
- (vector-set! label-map (label->idx k) #t)
- (for-each (lambda (k)
- ;; Visit predecessors unless they are already visited.
- (unless (vector-ref label-map (label->idx k))
- (visit k)))
- (lookup-predecessors k dfg))
- ;; Add to reverse post-order chain.
- (vector-set! label-map (label->idx k) next)
- (set! next k))
-
- (let lp ((n 0) (head next))
- (if (< head 0)
- ;; Add nodes that are not reachable from the tail.
- (let lp ((n n) (m label-count))
- (unless (= n label-count)
- (let find-unvisited ((m (1- m)))
- (if (vector-ref label-map m)
- (find-unvisited (1- m))
- (begin
- (vector-set! label-map m n)
- (lp (1+ n) m))))))
- ;; Pop the head off the chain, give it its
- ;; reverse-post-order numbering, and continue.
- (let ((next (vector-ref label-map (label->idx head))))
- (vector-set! label-map (label->idx head) n)
- (lp (1+ n) next))))
-
- label-map))
-
- (define (convert-successors k-map)
- (define (idx->label idx) (+ idx min-label))
- (define (renumber label)
- (vector-ref k-map (- label min-label)))
- (let ((succs (make-vector (vector-length k-map) #f)))
- (let lp ((n 0))
- (when (< n (vector-length succs))
- (vector-set! succs (vector-ref k-map n)
- (map renumber
- (lookup-successors (idx->label n) dfg)))
- (lp (1+ n))))
- succs))
-
- (match fun
- (($ $cont kfun ($ $kfun src meta self ($ $cont ktail tail)))
- (let* ((k-map (compute-reverse-control-flow-order ktail dfg))
- (succs (convert-successors k-map)))
- ;; Any expression in the prompt body could cause an abort to
- ;; the handler. This code adds links from every block in the
- ;; prompt body to the handler. This causes all values used
- ;; by the handler to be seen as live in the prompt body, as
- ;; indeed they are.
- (visit-prompt-control-flow
- dfg min-label label-count
- (lambda (prompt handler body)
- (define (renumber label)
- (vector-ref k-map (- label min-label)))
- (vector-push! succs (renumber body) (renumber handler))))
-
- (values k-map succs)))))
-
-(define (compute-idoms dfg min-label label-count)
- (define preds (dfg-preds dfg))
- (define (label->idx label) (- label min-label))
- (define (idx->label idx) (+ idx min-label))
- (define (idx->dfg-idx idx) (- (idx->label idx) (dfg-min-label dfg)))
- (let ((idoms (make-vector label-count #f)))
- (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.
- (cond
- ((= d0 d1) d0)
- ((< d0 d1) (common-idom d0 (vector-ref idoms (label->idx d1))))
- (else (common-idom (vector-ref idoms (label->idx d0)) d1))))
- (define (compute-idom preds)
- (define (has-idom? pred)
- (vector-ref idoms (label->idx pred)))
- (match preds
- (() min-label)
- ((pred . preds)
- (if (has-idom? pred)
- (let lp ((idom pred) (preds preds))
- (match preds
- (() idom)
- ((pred . preds)
- (lp (if (has-idom? pred)
- (common-idom idom pred)
- idom)
- preds))))
- (compute-idom preds)))))
- ;; 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 iterate ((n 0) (changed? #f))
- (cond
- ((< n label-count)
- (let ((idom (vector-ref idoms n))
- (idom* (compute-idom (vector-ref preds (idx->dfg-idx n)))))
- (cond
- ((eqv? idom idom*)
- (iterate (1+ n) changed?))
- (else
- (vector-set! idoms n idom*)
- (iterate (1+ n) #t)))))
- (changed?
- (iterate 0 #f))
- (else idoms)))))
-
-;; 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 min-label)
- (define (label->idx label) (- label min-label))
- (define (idx->label idx) (+ idx min-label))
- (let ((doms (make-vector (vector-length idoms) '())))
- (let lp ((n 0))
- (when (< n (vector-length idoms))
- (let ((idom (vector-ref idoms n)))
- (vector-push! doms (label->idx idom) (idx->label n)))
- (lp (1+ n))))
- doms))
-
-;; There used to be some loop detection code here, but it bitrotted.
-;; We'll need it again eventually but for now it can be found in the git
-;; history.
-
-;; Data-flow analysis.
-(define-record-type $dfa
- (make-dfa min-label min-var var-count in out)
- dfa?
- ;; Minimum label in this function.
- (min-label dfa-min-label)
- ;; Minimum var in this function.
- (min-var dfa-min-var)
- ;; Var count in this function.
- (var-count dfa-var-count)
- ;; Vector of k-idx -> intset
- (in dfa-in)
- ;; Vector of k-idx -> intset
- (out dfa-out))
-
-(define (dfa-k-idx dfa k)
- (- k (dfa-min-label dfa)))
-
-(define (dfa-k-sym dfa idx)
- (+ idx (dfa-min-label dfa)))
-
-(define (dfa-k-count dfa)
- (vector-length (dfa-in dfa)))
-
-(define (dfa-var-idx dfa var)
- (let ((idx (- var (dfa-min-var dfa))))
- (unless (< -1 idx (dfa-var-count dfa))
- (error "var out of range" var))
- idx))
-
-(define (dfa-var-sym dfa idx)
- (unless (< -1 idx (dfa-var-count dfa))
- (error "idx out of range" idx))
- (+ idx (dfa-min-var dfa)))
-
-(define (dfa-k-in dfa idx)
- (vector-ref (dfa-in dfa) idx))
-
-(define (dfa-k-out dfa idx)
- (vector-ref (dfa-out dfa) idx))
-
-(define (compute-live-variables fun dfg)
- ;; Compute the maximum fixed point of the data-flow constraint problem.
- ;;
- ;; This always completes, as the graph is finite and the in and out sets
- ;; are complete semi-lattices. If the graph is reducible and the blocks
- ;; are sorted in reverse post-order, this completes in a maximum of LC +
- ;; 2 iterations, where LC is the loop connectedness number. See Hecht
- ;; and Ullman, "Analysis of a simple algorithm for global flow
- ;; problems", POPL 1973, or the recent summary in "Notes on graph
- ;; algorithms used in optimizing compilers", Offner 2013.
- (define (compute-maximum-fixed-point preds inv outv killv genv)
- (define (fold f seed l)
- (if (null? l) seed (fold f (f (car l) seed) (cdr l))))
- (let lp ((n 0) (changed? #f))
- (cond
- ((< n (vector-length preds))
- (let* ((in (vector-ref inv n))
- (in* (or
- (fold (lambda (pred set)
- (cond
- ((vector-ref outv pred)
- => (lambda (out)
- (if set
- (intset-union set out)
- out)))
- (else set)))
- in
- (vector-ref preds n))
- empty-intset)))
- (if (eq? in in*)
- (lp (1+ n) changed?)
- (let ((out* (fold (lambda (gen set)
- (intset-add set gen))
- (fold (lambda (kill set)
- (intset-remove set kill))
- in*
- (vector-ref killv n))
- (vector-ref genv n))))
- (vector-set! inv n in*)
- (vector-set! outv n out*)
- (lp (1+ n) #t)))))
- (changed?
- (lp 0 #f)))))
-
- (unless (and (= (vector-length (dfg-uses dfg)) (dfg-var-count dfg))
- (= (vector-length (dfg-cont-table dfg)) (dfg-label-count dfg)))
- (error "function needs renumbering"))
- (let* ((min-label (dfg-min-label dfg))
- (nlabels (dfg-label-count dfg))
- (min-var (dfg-min-var dfg))
- (nvars (dfg-var-count dfg))
- (usev (make-vector nlabels '()))
- (defv (make-vector nlabels '()))
- (live-in (make-vector nlabels #f))
- (live-out (make-vector nlabels #f)))
- (call-with-values
- (lambda ()
- (analyze-reverse-control-flow fun dfg min-label nlabels))
- (lambda (k-map succs)
- (define (var->idx var) (- var min-var))
- (define (idx->var idx) (+ idx min-var))
- (define (label->idx label)
- (vector-ref k-map (- label min-label)))
-
- ;; Initialize defv and usev.
- (let ((defs (dfg-defs dfg))
- (uses (dfg-uses dfg)))
- (let lp ((n 0))
- (when (< n (vector-length defs))
- (let ((def (vector-ref defs n)))
- (unless def
- (error "internal error -- var array not packed"))
- (for-each (lambda (def)
- (vector-push! defv (label->idx def) n))
- (lookup-predecessors def dfg))
- (for-each (lambda (use)
- (vector-push! usev (label->idx use) n))
- (vector-ref uses n))
- (lp (1+ n))))))
-
- ;; Liveness is a reverse data-flow problem, so we give
- ;; compute-maximum-fixed-point a reversed graph, swapping in for
- ;; out, usev for defv, and using successors instead of
- ;; predecessors. Continuation 0 is ktail.
- (compute-maximum-fixed-point succs live-out live-in defv usev)
-
- ;; Now rewrite the live-in and live-out sets to be indexed by
- ;; (LABEL - MIN-LABEL).
- (let ((live-in* (make-vector nlabels #f))
- (live-out* (make-vector nlabels #f)))
- (let lp ((idx 0))
- (when (< idx nlabels)
- (let ((dfa-idx (vector-ref k-map idx)))
- (vector-set! live-in* idx (vector-ref live-in dfa-idx))
- (vector-set! live-out* idx (vector-ref live-out dfa-idx))
- (lp (1+ idx)))))
-
- (make-dfa min-label min-var nvars live-in* live-out*))))))
-
-(define (print-dfa dfa)
- (match dfa
- (($ $dfa min-label min-var var-count in out)
- (define (print-var-set bv)
- (let lp ((n 0))
- (let ((n (intset-next bv n)))
- (when n
- (format #t " ~A" (+ n min-var))
- (lp (1+ n))))))
- (let lp ((n 0))
- (when (< n (vector-length in))
- (format #t "~A:\n" (+ n min-label))
- (format #t " in:")
- (print-var-set (vector-ref in n))
- (newline)
- (format #t " out:")
- (print-var-set (vector-ref out n))
- (newline)
- (lp (1+ n)))))))
-
-(define (compute-label-and-var-ranges fun global?)
- (define (min* a b)
- (if b (min a b) a))
- (define-syntax-rule (do-fold make-cont-folder)
- ((make-cont-folder min-label max-label label-count
- min-var max-var var-count)
- (lambda (label cont
- min-label max-label label-count
- min-var max-var var-count)
- (let ((min-label (min* label min-label))
- (max-label (max label max-label)))
- (match cont
- (($ $kargs names vars body)
- (values min-label max-label (1+ label-count)
- (cond (min-var (fold min min-var vars))
- ((pair? vars) (fold min (car vars) (cdr vars)))
- (else min-var))
- (fold max max-var vars)
- (+ var-count (length vars))))
- (($ $kfun src meta self)
- (values min-label max-label (1+ label-count)
- (min* self min-var) (max self max-var) (1+ var-count)))
- (_ (values min-label max-label (1+ label-count)
- min-var max-var var-count)))))
- fun
- #f -1 0 #f -1 0))
- (if global?
- (do-fold make-global-cont-folder)
- (do-fold make-local-cont-folder)))
-
-(define* (compute-dfg fun #:key (global? #t))
- (call-with-values (lambda () (compute-label-and-var-ranges fun global?))
- (lambda (min-label max-label label-count min-var max-var var-count)
- (when (or (zero? label-count) (zero? var-count))
- (error "internal error (no vars or labels for fun?)"))
- (let* ((nlabels (- (1+ max-label) min-label))
- (nvars (- (1+ max-var) min-var))
- (conts (make-vector nlabels #f))
- (preds (make-vector nlabels '()))
- (defs (make-vector nvars #f))
- (uses (make-vector nvars '()))
- (scopes (make-vector nlabels #f))
- (scope-levels (make-vector nlabels #f)))
- (define (var->idx var) (- var min-var))
- (define (label->idx label) (- label min-label))
-
- (define (add-def! var def-k)
- (vector-set! defs (var->idx var) def-k))
- (define (add-use! var use-k)
- (vector-push! uses (var->idx var) use-k))
-
- (define* (declare-block! label cont parent
- #:optional (level
- (1+ (vector-ref
- scope-levels
- (label->idx parent)))))
- (vector-set! conts (label->idx label) cont)
- (vector-set! scopes (label->idx label) parent)
- (vector-set! scope-levels (label->idx label) level))
-
- (define (link-blocks! pred succ)
- (vector-push! preds (label->idx succ) pred))
-
- (define (visit-cont cont label)
- (match cont
- (($ $kargs names syms body)
- (for-each (cut add-def! <> label) syms)
- (visit-term body label))
- (($ $kreceive arity k)
- (link-blocks! label k))))
-
- (define (visit-term term label)
- (match term
- (($ $letk (($ $cont k cont) ...) body)
- ;; Set up recursive environment before visiting cont bodies.
- (for-each/2 (lambda (cont k)
- (declare-block! k cont label))
- cont k)
- (for-each/2 visit-cont cont k)
- (visit-term body label))
- (($ $continue k src exp)
- (link-blocks! label k)
- (visit-exp exp label))))
-
- (define (visit-exp exp label)
- (define (use! sym)
- (add-use! sym label))
- (match exp
- ((or ($ $const) ($ $prim) ($ $closure)) #f)
- (($ $call proc args)
- (use! proc)
- (for-each use! args))
- (($ $callk k proc args)
- (use! proc)
- (for-each use! args))
- (($ $primcall name args)
- (for-each use! args))
- (($ $branch kt exp)
- (link-blocks! label kt)
- (visit-exp exp label))
- (($ $values args)
- (for-each use! args))
- (($ $prompt escape? tag handler)
- (use! tag)
- (link-blocks! label handler))
- (($ $fun body)
- (when global?
- (visit-fun body)))
- (($ $rec names syms funs)
- (unless global?
- (error "$rec should not be present when building a local DFG"))
- (for-each (lambda (fun)
- (match fun
- (($ $fun body)
- (visit-fun body))))
- funs))))
-
- (define (visit-clause clause kfun)
- (match clause
- (#f #t)
- (($ $cont kclause
- (and clause ($ $kclause arity ($ $cont kbody body)
- alternate)))
- (declare-block! kclause clause kfun)
- (link-blocks! kfun kclause)
-
- (declare-block! kbody body kclause)
- (link-blocks! kclause kbody)
-
- (visit-cont body kbody)
- (visit-clause alternate kfun))))
-
- (define (visit-fun fun)
- (match fun
- (($ $cont kfun
- (and cont
- ($ $kfun src meta self ($ $cont ktail tail) clause)))
- (declare-block! kfun cont #f 0)
- (add-def! self kfun)
- (declare-block! ktail tail kfun)
- (visit-clause clause kfun))))
-
- (visit-fun fun)
-
- (make-dfg conts preds defs uses scopes scope-levels
- min-label max-label label-count
- min-var max-var var-count)))))
-
-(define* (dump-dfg dfg #:optional (port (current-output-port)))
- (let ((min-label (dfg-min-label dfg))
- (min-var (dfg-min-var dfg)))
- (define (label->idx label) (- label min-label))
- (define (idx->label idx) (+ idx min-label))
- (define (var->idx var) (- var min-var))
- (define (idx->var idx) (+ idx min-var))
-
- (let lp ((label (dfg-min-label dfg)))
- (when (<= label (dfg-max-label dfg))
- (let ((cont (vector-ref (dfg-cont-table dfg) (label->idx label))))
- (when cont
- (unless (equal? (lookup-predecessors label dfg) (list (1- label)))
- (newline port))
- (format port "k~a:~8t" label)
- (match cont
- (($ $kreceive arity k)
- (format port "$kreceive ~a k~a\n" arity k))
- (($ $kfun src meta self tail clause)
- (format port "$kfun ~a ~a v~a\n" src meta self))
- (($ $ktail)
- (format port "$ktail\n"))
- (($ $kclause arity ($ $cont kbody) alternate)
- (format port "$kclause ~a k~a" arity kbody)
- (match alternate
- (#f #f)
- (($ $cont kalt) (format port " -> k~a" kalt)))
- (newline port))
- (($ $kargs names vars term)
- (unless (null? vars)
- (format port "v~a[~a]~:{ v~a[~a]~}: "
- (car vars) (car names) (map list (cdr vars) (cdr
names))))
- (match (find-call term)
- (($ $continue kf src ($ $branch kt exp))
- (format port "if ")
- (match exp
- (($ $primcall name args)
- (format port "(~a~{ v~a~})" name args))
- (($ $values (arg))
- (format port "v~a" arg)))
- (format port " k~a k~a\n" kt kf))
- (($ $continue k src exp)
- (match exp
- (($ $const val) (format port "const address@hidden" val))
- (($ $prim name) (format port "prim ~a" name))
- (($ $fun ($ $cont kbody)) (format port "fun k~a" kbody))
- (($ $rec names syms funs) (format port "rec~{ v~a~}" syms))
- (($ $closure label nfree) (format port "closure k~a (~a
free)" label nfree))
- (($ $call proc args) (format port "call~{ v~a~}" (cons
proc args)))
- (($ $callk k proc args) (format port "callk k~a~{ v~a~}" k
(cons proc args)))
- (($ $primcall name args) (format port "~a~{ v~a~}" name
args))
- (($ $values args) (format port "values~{ v~a~}" args))
- (($ $prompt escape? tag handler) (format port "prompt ~a
v~a k~a" escape? tag handler)))
- (unless (= k (1+ label))
- (format port " -> k~a" k))
- (newline port))))))
- (lp (1+ label)))))))
-
-(define-syntax-rule (with-fresh-name-state-from-dfg dfg body ...)
- (parameterize ((label-counter (1+ (dfg-max-label dfg)))
- (var-counter (1+ (dfg-max-var dfg))))
- body ...))
-
-(define (lookup-cont label dfg)
- (let ((res (vector-ref (dfg-cont-table dfg) (- label (dfg-min-label dfg)))))
- (unless res
- (error "Unknown continuation!" label))
- res))
-
-(define (lookup-predecessors k dfg)
- (vector-ref (dfg-preds dfg) (- k (dfg-min-label dfg))))
-
-(define (lookup-successors k dfg)
- (let ((cont (vector-ref (dfg-cont-table dfg) (- k (dfg-min-label dfg)))))
- (visit-cont-successors list cont)))
-
-(define (lookup-def var dfg)
- (vector-ref (dfg-defs dfg) (- var (dfg-min-var dfg))))
-
-(define (lookup-uses var dfg)
- (vector-ref (dfg-uses dfg) (- var (dfg-min-var dfg))))
-
-(define (lookup-block-scope k dfg)
- (vector-ref (dfg-scopes dfg) (- k (dfg-min-label dfg))))
-
-(define (lookup-scope-level k dfg)
- (vector-ref (dfg-scope-levels dfg) (- k (dfg-min-label dfg))))
-
-(define (find-defining-term sym dfg)
- (match (lookup-predecessors (lookup-def sym dfg) dfg)
- ((def-exp-k)
- (lookup-cont def-exp-k dfg))
- (else #f)))
-
-(define (find-call term)
- (match term
- (($ $kargs names syms body) (find-call body))
- (($ $letk conts body) (find-call body))
- (($ $continue) term)))
-
-(define (call-expression call)
- (match call
- (($ $continue k src exp) exp)))
-
-(define (find-expression term)
- (call-expression (find-call term)))
-
-(define (find-defining-expression sym dfg)
- (match (find-defining-term sym dfg)
- (#f #f)
- (($ $kreceive) #f)
- (($ $kclause) #f)
- (term (find-expression term))))
-
-(define (find-constant-value sym dfg)
- (match (find-defining-expression sym dfg)
- (($ $const val)
- (values #t val))
- (else
- (values #f #f))))
-
-(define (constant-needs-allocation? var val dfg)
- (define (immediate-u8? val)
- (and (integer? val) (exact? val) (<= 0 val 255)))
-
- (define (find-exp term)
- (match term
- (($ $kargs names vars body) (find-exp body))
- (($ $letk conts body) (find-exp body))
- (else term)))
-
- (or-map
- (lambda (use)
- (match (find-expression (lookup-cont use dfg))
- (($ $call) #f)
- (($ $callk) #f)
- (($ $values) #f)
- (($ $primcall 'free-ref (closure slot))
- (eq? var closure))
- (($ $primcall 'free-set! (closure slot value))
- (or (eq? var closure) (eq? var value)))
- (($ $primcall 'cache-current-module! (mod . _))
- (eq? var mod))
- (($ $primcall 'cached-toplevel-box _)
- #f)
- (($ $primcall 'cached-module-box _)
- #f)
- (($ $primcall 'resolve (name bound?))
- (eq? var name))
- (($ $primcall 'make-vector/immediate (len init))
- (eq? var init))
- (($ $primcall 'vector-ref/immediate (v i))
- (eq? var v))
- (($ $primcall 'vector-set!/immediate (v i x))
- (or (eq? var v) (eq? var x)))
- (($ $primcall 'allocate-struct/immediate (vtable nfields))
- (eq? var vtable))
- (($ $primcall 'struct-ref/immediate (s n))
- (eq? var s))
- (($ $primcall 'struct-set!/immediate (s n x))
- (or (eq? var s) (eq? var x)))
- (($ $primcall 'builtin-ref (idx))
- #f)
- (_ #t)))
- (vector-ref (dfg-uses dfg) (- var (dfg-min-var dfg)))))
-
-(define (continuation-scope-contains? scope-k k dfg)
- (let ((scope-level (lookup-scope-level scope-k dfg)))
- (let lp ((k k))
- (or (eq? scope-k k)
- (and (< scope-level (lookup-scope-level k dfg))
- (lp (lookup-block-scope k dfg)))))))
-
-(define (continuation-bound-in? k use-k dfg)
- (continuation-scope-contains? (lookup-block-scope k dfg) use-k dfg))
-
-(define (variable-free-in? var k dfg)
- (or-map (lambda (use)
- (continuation-scope-contains? k use dfg))
- (lookup-uses var dfg)))
-
-;; A continuation is a control point if it has multiple predecessors, or
-;; if its single predecessor does not have a single successor.
-(define (control-point? k dfg)
- (match (lookup-predecessors k dfg)
- ((pred)
- (let ((cont (vector-ref (dfg-cont-table dfg)
- (- pred (dfg-min-label dfg)))))
- (visit-cont-successors (case-lambda
- (() #t)
- ((succ0) #f)
- ((succ1 succ2) #t))
- cont)))
- (_ #t)))
-
-(define (lookup-bound-syms k dfg)
- (match (lookup-cont k dfg)
- (($ $kargs names syms body)
- syms)))
diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
deleted file mode 100644
index 8a1c7a0..0000000
--- a/module/language/cps/renumber.scm
+++ /dev/null
@@ -1,343 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 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 cps renumber)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-1)
- #:use-module (language cps)
- #:export (renumber))
-
-;; Topologically sort the continuation tree starting at k0, using
-;; reverse post-order numbering.
-(define (sort-conts k0 conts new-k0 path-lengths)
- (let ((next -1))
- (let visit ((k k0))
- (define (maybe-visit k)
- (let ((entry (vector-ref conts k)))
- ;; Visit the successor if it has not been
- ;; visited yet.
- (when (and entry (not (exact-integer? entry)))
- (visit k))))
-
- (let ((cont (vector-ref conts k)))
- ;; Clear the cont table entry to mark this continuation as
- ;; visited.
- (vector-set! conts k #f)
-
- (match cont
- (($ $kargs names syms body)
- (let lp ((body body))
- (match body
- (($ $letk conts body) (lp body))
- (($ $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 (vector-ref path-lengths k))
- (kt-len (vector-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 ($ $cont kbody) alt)
- (match alt
- (($ $cont kalt) (maybe-visit kalt))
- (_ #f))
- (maybe-visit kbody))
- (($ $kfun src meta self tail clause)
- (match clause
- (($ $cont kclause) (maybe-visit kclause))
- (_ #f)))
- (_ #f))
-
- ;; Chain this label to the label that will follow it in the sort
- ;; order, and record this label as the new head of the order.
- (vector-set! conts k next)
- (set! next k)))
-
- ;; Finally traverse the label chain, giving each label its final
- ;; name.
- (let lp ((n new-k0) (head next))
- (if (< head 0)
- n
- (let ((next (vector-ref conts head)))
- (vector-set! conts head n)
- (lp (1+ n) next))))))
-
-(define (compute-tail-path-lengths preds ktail path-lengths)
- (let visit ((k ktail) (length-in 0))
- (let ((length (vector-ref path-lengths k)))
- (unless (and length (<= length length-in))
- (vector-set! path-lengths k length-in)
- (let lp ((preds (vector-ref preds k)))
- (match preds
- (() #t)
- ((pred . preds)
- (visit pred (1+ length-in))
- (lp preds))))))))
-
-(define (compute-new-labels-and-vars fun)
- (call-with-values (lambda () (compute-max-label-and-var fun))
- (lambda (max-label max-var)
- (let ((labels (make-vector (1+ max-label) #f))
- (next-label 0)
- (vars (make-vector (1+ max-var) #f))
- (next-var 0)
- (preds (make-vector (1+ max-label) '()))
- (path-lengths (make-vector (1+ max-label) #f)))
- (define (add-predecessor! pred succ)
- (vector-set! preds succ (cons pred (vector-ref preds succ))))
- (define (rename! var)
- (vector-set! vars var next-var)
- (set! next-var (1+ next-var)))
-
- (define (collect-conts fun)
- (define (visit-cont cont)
- (match cont
- (($ $cont label cont)
- (vector-set! labels label cont)
- (match cont
- (($ $kargs names vars body)
- (visit-term body label))
- (($ $kfun src meta self tail clause)
- (visit-cont tail)
- (match clause
- (($ $cont kclause)
- (add-predecessor! label kclause)
- (visit-cont clause))
- (#f #f)))
- (($ $kclause arity (and body ($ $cont kbody)) alternate)
- (add-predecessor! label kbody)
- (visit-cont body)
- (match alternate
- (($ $cont kalt)
- (add-predecessor! label kalt)
- (visit-cont alternate))
- (#f #f)))
- (($ $kreceive arity kargs)
- (add-predecessor! label kargs))
- (($ $ktail) #f)))))
- (define (visit-term term label)
- (match term
- (($ $letk conts body)
- (let lp ((conts conts))
- (unless (null? conts)
- (visit-cont (car conts))
- (lp (cdr conts))))
- (visit-term body label))
- (($ $continue k src exp)
- (add-predecessor! label k)
- (match exp
- (($ $branch kt)
- (add-predecessor! label kt))
- (($ $prompt escape? tag handler)
- (add-predecessor! label handler))
- (_ #f)))))
- (visit-cont fun))
-
- (define (compute-names-in-fun fun)
- (define queue '())
- (define (visit-cont cont)
- (match cont
- (($ $cont label cont)
- (let ((reachable? (exact-integer? (vector-ref labels label))))
- ;; This cont is reachable if it was given a number.
- ;; Otherwise the cont table entry still contains the
- ;; cont itself; clear it out to indicate that the cont
- ;; should not be residualized.
- (unless reachable?
- (vector-set! labels label #f))
- (match cont
- (($ $kargs names vars body)
- (when reachable?
- (for-each rename! vars))
- (visit-term body reachable?))
- (($ $kfun src meta self tail clause)
- (unless reachable? (error "entry should be reachable"))
- (rename! self)
- (visit-cont tail)
- (when clause
- (visit-cont clause)))
- (($ $kclause arity body alternate)
- (unless reachable? (error "clause should be reachable"))
- (visit-cont body)
- (when alternate
- (visit-cont alternate)))
- (($ $ktail)
- (unless reachable?
- ;; It's possible for the tail to be unreachable,
- ;; if all paths contify to infinite loops. Make
- ;; sure we mark as reachable.
- (vector-set! labels label next-label)
- (set! next-label (1+ next-label))))
- (($ $kreceive)
- #f))))))
- (define (visit-term term reachable?)
- (match term
- (($ $letk conts body)
- (for-each visit-cont conts)
- (visit-term body reachable?))
- (($ $continue k src ($ $fun body))
- (when reachable?
- (set! queue (cons body queue))))
- (($ $continue k src ($ $rec names syms funs))
- (when reachable?
- (set! queue (fold (lambda (fun queue)
- (match fun
- (($ $fun body)
- (cons body queue))))
- queue
- funs))))
- (($ $continue) #f)))
-
- (match fun
- (($ $cont kfun ($ $kfun src meta self ($ $cont ktail)))
- (collect-conts fun)
- (compute-tail-path-lengths preds ktail path-lengths)
- (set! next-label (sort-conts kfun labels next-label path-lengths))
- (visit-cont fun)
- (for-each compute-names-in-fun (reverse queue)))
- (($ $program conts)
- (for-each compute-names-in-fun conts))))
-
- (compute-names-in-fun fun)
- (values labels vars next-label next-var)))))
-
-(define (apply-renumbering term labels vars)
- (define (relabel label) (vector-ref labels label))
- (define (rename var) (vector-ref vars var))
- (define (rename-kw-arity arity)
- (match arity
- (($ $arity req opt rest kw aok?)
- (make-$arity req opt rest
- (map (match-lambda
- ((kw kw-name kw-var)
- (list kw kw-name (rename kw-var))))
- kw)
- aok?))))
- (define (must-visit-cont cont)
- (or (visit-cont cont)
- (error "internal error -- failed to visit cont")))
- (define (visit-conts conts)
- (match conts
- (() '())
- ((cont . conts)
- (cond
- ((visit-cont cont)
- => (lambda (cont)
- (cons cont (visit-conts conts))))
- (else (visit-conts conts))))))
- (define (visit-cont cont)
- (match cont
- (($ $cont label cont)
- (let ((label (relabel label)))
- (and
- label
- (rewrite-cps-cont cont
- (($ $kargs names vars body)
- (label ($kargs names (map rename vars) ,(visit-term body))))
- (($ $kfun src meta self tail clause)
- (label
- ($kfun src meta (rename self) ,(must-visit-cont tail)
- ,(and clause (must-visit-cont clause)))))
- (($ $ktail)
- (label ($ktail)))
- (($ $kclause arity body alternate)
- (label
- ($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
- ,(and alternate (must-visit-cont alternate)))))
- (($ $kreceive ($ $arity req () rest () #f) kargs)
- (label ($kreceive req rest (relabel kargs))))))))))
- (define (visit-term term)
- (rewrite-cps-term term
- (($ $letk conts body)
- ,(match (visit-conts conts)
- (() (visit-term body))
- (conts (build-cps-term ($letk ,conts ,(visit-term body))))))
- (($ $continue k src exp)
- ($continue (relabel k) src ,(visit-exp exp)))))
- (define (visit-exp exp)
- (match exp
- ((or ($ $const) ($ $prim))
- exp)
- (($ $closure k nfree)
- (build-cps-exp ($closure (relabel k) nfree)))
- (($ $fun)
- (visit-fun exp))
- (($ $rec names vars funs)
- (build-cps-exp ($rec names (map rename vars) (map visit-fun funs))))
- (($ $values args)
- (let ((args (map rename args)))
- (build-cps-exp ($values args))))
- (($ $call proc args)
- (let ((args (map rename args)))
- (build-cps-exp ($call (rename proc) args))))
- (($ $callk k proc args)
- (let ((args (map rename args)))
- (build-cps-exp ($callk (relabel k) (rename proc) args))))
- (($ $branch kt exp)
- (build-cps-exp ($branch (relabel kt) ,(visit-exp exp))))
- (($ $primcall name args)
- (let ((args (map rename args)))
- (build-cps-exp ($primcall name args))))
- (($ $prompt escape? tag handler)
- (build-cps-exp
- ($prompt escape? (rename tag) (relabel handler))))))
- (define (visit-fun fun)
- (rewrite-cps-exp fun
- (($ $fun body)
- ($fun ,(must-visit-cont body)))))
-
- (match term
- (($ $cont)
- (must-visit-cont term))
- (($ $program conts)
- (build-cps-term
- ($program ,(map must-visit-cont conts))))))
-
-(define (renumber term)
- (call-with-values (lambda () (compute-new-labels-and-vars term))
- (lambda (labels vars nlabels nvars)
- (values (apply-renumbering term labels vars) nlabels nvars))))
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
deleted file mode 100644
index c60f0f2..0000000
--- a/module/language/cps/slot-allocation.scm
+++ /dev/null
@@ -1,689 +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 module to assign stack slots to variables in a CPS term.
-;;;
-;;; Code:
-
-(define-module (language cps slot-allocation)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-26)
- #:use-module (language cps)
- #:use-module (language cps dfg)
- #:use-module (language cps intset)
- #:export (allocate-slots
- lookup-slot
- lookup-maybe-slot
- lookup-constant-value
- lookup-maybe-constant-value
- lookup-nlocals
- lookup-call-proc-slot
- lookup-parallel-moves
- lookup-dead-slot-map))
-
-(define-record-type $allocation
- (make-allocation dfa slots
- has-constv constant-values
- call-allocations
- nlocals)
- allocation?
-
- ;; A DFA records all variables bound in a function, and assigns them
- ;; indices. The slot in which a variable is stored at runtime can be
- ;; had by indexing into the SLOTS vector with the variable's index.
- ;;
- (dfa allocation-dfa)
- (slots allocation-slots)
-
- ;; Not all variables have slots allocated. Variables that are
- ;; constant and that are only used by primcalls that can accept
- ;; constants directly are not allocated to slots, and their SLOT value
- ;; is false. Likewise constants that are only used by calls are not
- ;; allocated into slots, to avoid needless copying. If a variable is
- ;; constant, its constant value is set in the CONSTANT-VALUES vector
- ;; and the corresponding bit in the HAS-CONSTV bitvector is set.
- ;;
- (has-constv allocation-has-constv)
- (constant-values allocation-constant-values)
-
- ;; Some continuations have additional associated information. This
- ;; addition information is a /call allocation/. Call allocations
- ;; record the way that functions are passed values, and how their
- ;; return values are rebound to local variables.
- ;;
- ;; A call allocation contains three pieces of information: the call's
- ;; /proc slot/, a set of /parallel moves/, and a /dead slot map/. The
- ;; proc slot indicates the slot of a procedure in a procedure call, or
- ;; where the procedure would be in a multiple-value return. The
- ;; parallel moves shuffle locals into position for a call, or shuffle
- ;; returned values back into place. Though they use the same slot,
- ;; moves for a call are called "call moves", and moves to handle a
- ;; return are "return moves". The dead slot map indicates, for a
- ;; call, what slots should be ignored by GC when marking the frame.
- ;;
- ;; $kreceive continuations record a proc slot and a set of return moves
- ;; to adapt multiple values from the stack to local variables.
- ;;
- ;; Tail calls record arg moves, but no proc slot.
- ;;
- ;; Non-tail calls record arg moves, a call slot, and a dead slot map.
- ;; Multiple-valued returns will have an associated $kreceive
- ;; continuation, which records the same proc slot, but has return
- ;; moves and no dead slot map.
- ;;
- ;; $prompt handlers are $kreceive continuations like any other.
- ;;
- ;; $values expressions with more than 1 value record moves but have no
- ;; proc slot or dead slot map.
- ;;
- ;; A set of moves is expressed as an ordered list of (SRC . DST)
- ;; moves, where SRC and DST are slots. This may involve a temporary
- ;; variable. A dead slot map is a bitfield, as an integer.
- ;;
- (call-allocations allocation-call-allocations)
-
- ;; The number of locals for a $kclause.
- ;;
- (nlocals allocation-nlocals))
-
-(define-record-type $call-allocation
- (make-call-allocation proc-slot moves dead-slot-map)
- call-allocation?
- (proc-slot call-allocation-proc-slot)
- (moves call-allocation-moves)
- (dead-slot-map call-allocation-dead-slot-map))
-
-(define (find-first-zero n)
- ;; Naive implementation.
- (let lp ((slot 0))
- (if (logbit? slot n)
- (lp (1+ slot))
- slot)))
-
-(define (find-first-trailing-zero n)
- (let lp ((slot (let lp ((count 2))
- (if (< n (ash 1 (1- count)))
- count
- ;; Grow upper bound slower than factor 2 to avoid
- ;; needless bignum allocation on 32-bit systems
- ;; when there are more than 16 locals.
- (lp (+ count (ash count -1)))))))
- (if (or (zero? slot) (logbit? (1- slot) n))
- slot
- (lp (1- slot)))))
-
-(define (lookup-maybe-slot sym allocation)
- (match allocation
- (($ $allocation dfa slots)
- (vector-ref slots (dfa-var-idx dfa sym)))))
-
-(define (lookup-slot sym allocation)
- (or (lookup-maybe-slot sym allocation)
- (error "Variable not allocated to a slot" sym)))
-
-(define (lookup-constant-value sym allocation)
- (match allocation
- (($ $allocation dfa slots has-constv constant-values)
- (let ((idx (dfa-var-idx dfa sym)))
- (if (bitvector-ref has-constv idx)
- (vector-ref constant-values idx)
- (error "Variable does not have constant value" sym))))))
-
-(define (lookup-maybe-constant-value sym allocation)
- (match allocation
- (($ $allocation dfa slots has-constv constant-values)
- (let ((idx (dfa-var-idx dfa sym)))
- (values (bitvector-ref has-constv idx)
- (vector-ref constant-values idx))))))
-
-(define (lookup-call-allocation k allocation)
- (or (hashq-ref (allocation-call-allocations allocation) k)
- (error "Continuation not a call" k)))
-
-(define (lookup-call-proc-slot k allocation)
- (or (call-allocation-proc-slot (lookup-call-allocation k allocation))
- (error "Call has no proc slot" k)))
-
-(define (lookup-parallel-moves k allocation)
- (or (call-allocation-moves (lookup-call-allocation k allocation))
- (error "Call has no use parallel moves slot" k)))
-
-(define (lookup-dead-slot-map k allocation)
- (or (call-allocation-dead-slot-map (lookup-call-allocation k allocation))
- (error "Call has no dead slot map" k)))
-
-(define (lookup-nlocals k allocation)
- (or (hashq-ref (allocation-nlocals allocation) k)
- (error "Not a clause continuation" k)))
-
-(define (solve-parallel-move src dst tmp)
- "Solve the parallel move problem between src and dst slot lists, which
-are comparable with eqv?. A tmp slot may be used."
-
- ;; This algorithm is taken from: "Tilting at windmills with Coq:
- ;; formal verification of a compilation algorithm for parallel moves"
- ;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy
- ;; <http://gallium.inria.fr/~xleroy/publi/parallel-move.pdf>
-
- (define (split-move moves reg)
- (let loop ((revhead '()) (tail moves))
- (match tail
- (((and s+d (s . d)) . rest)
- (if (eqv? s reg)
- (cons d (append-reverse revhead rest))
- (loop (cons s+d revhead) rest)))
- (_ #f))))
-
- (define (replace-last-source reg moves)
- (match moves
- ((moves ... (s . d))
- (append moves (list (cons reg d))))))
-
- (let loop ((to-move (map cons src dst))
- (being-moved '())
- (moved '())
- (last-source #f))
- ;; 'last-source' should always be equivalent to:
- ;; (and (pair? being-moved) (car (last being-moved)))
- (match being-moved
- (() (match to-move
- (() (reverse moved))
- (((and s+d (s . d)) . t1)
- (if (or (eqv? s d) ; idempotent
- (not s)) ; src is a constant and can be loaded directly
- (loop t1 '() moved #f)
- (loop t1 (list s+d) moved s)))))
- (((and s+d (s . d)) . b)
- (match (split-move to-move d)
- ((r . t1) (loop t1 (acons d r being-moved) moved last-source))
- (#f (match b
- (() (loop to-move '() (cons s+d moved) #f))
- (_ (if (eqv? d last-source)
- (loop to-move
- (replace-last-source tmp b)
- (cons s+d (acons d tmp moved))
- tmp)
- (loop to-move b (cons s+d moved) last-source))))))))))
-
-(define (dead-after-def? k-idx v-idx dfa)
- (not (intset-ref (dfa-k-in dfa k-idx) v-idx)))
-
-(define (dead-after-use? k-idx v-idx dfa)
- (not (intset-ref (dfa-k-out dfa k-idx) v-idx)))
-
-(define (allocate-slots fun dfg)
- (let* ((dfa (compute-live-variables fun dfg))
- (min-label (dfg-min-label dfg))
- (label-count (dfg-label-count dfg))
- (usev (make-vector label-count '()))
- (defv (make-vector label-count '()))
- (slots (make-vector (dfa-var-count dfa) #f))
- (constant-values (make-vector (dfa-var-count dfa) #f))
- (has-constv (make-bitvector (dfa-var-count dfa) #f))
- (has-slotv (make-bitvector (dfa-var-count dfa) #t))
- (needs-slotv (make-bitvector (dfa-var-count dfa) #t))
- (needs-hintv (make-bitvector (dfa-var-count dfa) #f))
- (call-allocations (make-hash-table))
- (nlocals 0) ; Mutable. It pains me.
- (nlocals-table (make-hash-table)))
-
- (define (label->idx label) (- label min-label))
- (define (idx->label idx) (+ idx min-label))
-
- (define (bump-nlocals! nlocals*)
- (when (< nlocals nlocals*)
- (set! nlocals nlocals*)))
-
- (define (empty-live-slots)
- #b0)
-
- (define (add-live-slot slot live-slots)
- (logior live-slots (ash 1 slot)))
-
- (define (kill-dead-slot slot live-slots)
- (logand live-slots (lognot (ash 1 slot))))
-
- (define (compute-slot live-slots hint)
- ;; Slots 253-255 are reserved for shuffling; see comments in
- ;; assembler.scm.
- (if (and hint (not (logbit? hint live-slots))
- (or (< hint 253) (> hint 255)))
- hint
- (let ((slot (find-first-zero live-slots)))
- (if (or (< slot 253) (> slot 255))
- slot
- (+ 256 (find-first-zero (ash live-slots -256)))))))
-
- (define (compute-call-proc-slot live-slots)
- (+ 2 (find-first-trailing-zero live-slots)))
-
- (define (compute-prompt-handler-proc-slot live-slots)
- (if (zero? live-slots)
- 0
- (1- (find-first-trailing-zero live-slots))))
-
- (define (recompute-live-slots k)
- (let ((in (dfa-k-in dfa (label->idx k))))
- (let lp ((v 0) (live-slots 0))
- (let ((v (intset-next in v)))
- (if v
- (let ((slot (vector-ref slots v)))
- (lp (1+ v)
- (if slot
- (add-live-slot slot live-slots)
- live-slots)))
- live-slots)))))
-
- (define* (allocate! var-idx hint live)
- (cond
- ((not (bitvector-ref needs-slotv var-idx)) live)
- ((vector-ref slots var-idx) => (cut add-live-slot <> live))
- ((and (not hint) (bitvector-ref needs-hintv var-idx)) live)
- (else
- (let ((slot (compute-slot live hint)))
- (bump-nlocals! (1+ slot))
- (vector-set! slots var-idx slot)
- (add-live-slot slot live)))))
-
- ;; Although some parallel moves may proceed without a temporary
- ;; slot, in general one is needed. That temporary slot must not be
- ;; part of the source or destination sets, and that slot should not
- ;; correspond to a live variable. Usually the source and
- ;; destination sets are a subset of the union of the live sets
- ;; before and after the move. However for stack slots that don't
- ;; have names -- those slots that correspond to function arguments
- ;; or to function return values -- it could be that they are out of
- ;; the computed live set. In that case they need to be adjoined to
- ;; the live set, used when choosing a temporary slot.
- ;;
- ;; Note that although we reserve slots 253-255 for shuffling
- ;; operands that address less than the full 24-bit range of locals,
- ;; that reservation doesn't apply here, because this temporary
- ;; itself is used while doing parallel assignment via "mov", and
- ;; "mov" does not need shuffling.
- (define (compute-tmp-slot live stack-slots)
- (find-first-zero (fold add-live-slot live stack-slots)))
-
- (define (parallel-move src-slots dst-slots tmp-slot)
- (let ((moves (solve-parallel-move src-slots dst-slots tmp-slot)))
- (when (assv tmp-slot moves)
- (bump-nlocals! (1+ tmp-slot)))
- moves))
-
- ;; Find variables that are actually constant, and determine which
- ;; of those can avoid slot allocation.
- (define (compute-constants!)
- (let lp ((n 0))
- (when (< n (vector-length constant-values))
- (let ((sym (dfa-var-sym dfa n)))
- (call-with-values (lambda () (find-constant-value sym dfg))
- (lambda (has-const? const)
- (when has-const?
- (bitvector-set! has-constv n has-const?)
- (vector-set! constant-values n const)
- (when (not (constant-needs-allocation? sym const dfg))
- (bitvector-set! needs-slotv n #f)))
- (lp (1+ n))))))))
-
- ;; Record uses and defs, as lists of variable indexes, indexed by
- ;; label index.
- (define (compute-uses-and-defs!)
- (let lp ((n 0))
- (when (< n (vector-length usev))
- (match (lookup-cont (idx->label n) dfg)
- (($ $kfun src meta self)
- (vector-set! defv n (list (dfa-var-idx dfa self))))
- (($ $kargs names syms body)
- (vector-set! defv n (map (cut dfa-var-idx dfa <>) syms))
- (vector-set! usev n
- (map (cut dfa-var-idx dfa <>)
- (match (find-expression body)
- (($ $call proc args)
- (cons proc args))
- (($ $callk k proc args)
- (cons proc args))
- (($ $primcall name args)
- args)
- (($ $branch kt ($ $primcall name args))
- args)
- (($ $branch kt ($ $values args))
- args)
- (($ $values args)
- args)
- (($ $prompt escape? tag handler)
- (list tag))
- (_ '())))))
- (_ #f))
- (lp (1+ n)))))
-
- ;; Results of function calls that are not used don't need to be
- ;; allocated to slots.
- (define (compute-unused-results!)
- (define (kreceive-get-kargs kreceive)
- (match (lookup-cont kreceive dfg)
- (($ $kreceive arity kargs) kargs)
- (_ #f)))
- (let ((candidates (make-bitvector label-count #f)))
- ;; Find all $kargs that are the successors of $kreceive nodes.
- (let lp ((n 0))
- (when (< n label-count)
- (and=> (kreceive-get-kargs (idx->label n))
- (lambda (kargs)
- (bitvector-set! candidates (label->idx kargs) #t)))
- (lp (1+ n))))
- ;; For $kargs that only have $kreceive predecessors, remove unused
- ;; variables from the needs-slotv set.
- (let lp ((n 0))
- (let ((n (bit-position #t candidates n)))
- (when n
- (match (lookup-predecessors (idx->label n) dfg)
- ;; At least one kreceive is in the predecessor set, so we
- ;; only need to do the check for nodes with >1
- ;; predecessor.
- ((or (_) ((? kreceive-get-kargs) ...))
- (for-each (lambda (var)
- (when (dead-after-def? n var dfa)
- (bitvector-set! needs-slotv var #f)))
- (vector-ref defv n)))
- (_ #f))
- (lp (1+ n)))))))
-
- ;; Compute the set of variables whose allocation should be delayed
- ;; until a "hint" is known about where to allocate them. This is
- ;; the case for some procedure arguments.
- ;;
- ;; This algorithm used is a conservative approximation of what
- ;; really should happen, which would be eager allocation of call
- ;; frames as soon as it's known that a call will happen. It would
- ;; be nice to recast this as a proper data-flow problem.
- (define (compute-needs-hint!)
- (define (live-before n)
- (dfa-k-in dfa n))
- (define (live-after n)
- (dfa-k-out dfa n))
- (define needs-slot
- (bitvector->intset needs-slotv))
-
- ;; Walk backwards. At a call, compute the set of variables that
- ;; have allocated slots and are live before but not after. This
- ;; set contains candidates for needs-hintv.
- (define (scan-for-call n)
- (when (<= 0 n)
- (match (lookup-cont (idx->label n) dfg)
- (($ $kargs names syms body)
- (match (find-expression body)
- ((or ($ $call) ($ $callk))
- (let* ((args (intset-subtract (live-before n) (live-after n)))
- (args-needing-slots (intset-intersect args needs-slot)))
- (if (intset-next args-needing-slots #f)
- (scan-for-hints (1- n) args-needing-slots)
- (scan-for-call (1- n)))))
- (_ (scan-for-call (1- n)))))
- (_ (scan-for-call (1- n))))))
-
- ;; Walk backwards in the current basic block. Stop when the block
- ;; ends, we reach a call, or when an expression kills a value.
- (define (scan-for-hints n args)
- (when (< 0 n)
- (match (lookup-cont (idx->label n) dfg)
- (($ $kargs names syms body)
- (match (lookup-predecessors (idx->label (1+ n)) dfg)
- (((? (cut eqv? <> (idx->label n))))
- ;; If we are indeed in the same basic block, then if we
- ;; are finished with the scan, we kill uses of the
- ;; terminator, but leave its definitions.
- (match (find-expression body)
- ((or ($ $const) ($ $prim) ($ $closure)
- ($ $primcall) ($ $prompt)
- ;; If $values has more than one argument, it may
- ;; use a temporary, which would invalidate our
- ;; assumptions that slots not allocated are not
- ;; used.
- ($ $values (or () (_))))
- (define (intset-empty? intset) (not (intset-next intset)))
- (let ((killed (intset-subtract (live-before n) (live-after
n))))
- ;; If the expression kills no values needing slots,
- ;; and defines no value needing a slot that's not
- ;; in our args, then we keep on trucking.
- (if (intset-empty? (intset-intersect
- (fold (lambda (def clobber)
- (if (intset-ref args def)
- clobber
- (intset-add clobber def)))
- killed
- (vector-ref defv n))
- needs-slot))
- (scan-for-hints (1- n) args)
- (finish-hints n (live-before n) args))))
- ((or ($ $call) ($ $callk) ($ $values) ($ $branch))
- (finish-hints n (live-before n) args))))
- ;; Otherwise we kill uses of the block entry.
- (_ (finish-hints n (live-before (1+ n)) args))))
- (_ (finish-hints n (live-before (1+ n)) args)))))
-
- ;; Add definitions ARGS minus KILL to NEED-HINTS, and go back to
- ;; looking for calls.
- (define (finish-hints n kill args)
- (let ((new-hints (intset-subtract args kill)))
- (let lp ((n 0))
- (let ((n (intset-next new-hints n)))
- (when n
- (bitvector-set! needs-hintv n #t)
- (lp (1+ n))))))
- (scan-for-call n))
-
- (scan-for-call (1- label-count)))
-
- (define (allocate-call label k uses pre-live post-live)
- (match (lookup-cont k dfg)
- (($ $ktail)
- (let* ((tail-nlocals (length uses))
- (tail-slots (iota tail-nlocals))
- (pre-live (fold allocate! pre-live uses tail-slots))
- (moves (parallel-move (map (cut vector-ref slots <>) uses)
- tail-slots
- (compute-tmp-slot pre-live tail-slots))))
- (bump-nlocals! tail-nlocals)
- (hashq-set! call-allocations label
- (make-call-allocation #f moves #f))))
- (($ $kreceive arity kargs)
- (let* ((proc-slot (compute-call-proc-slot post-live))
- (call-slots (map (cut + proc-slot <>) (iota (length uses))))
- (pre-live (fold allocate! pre-live uses call-slots))
- (arg-moves (parallel-move (map (cut vector-ref slots <>) uses)
- call-slots
- (compute-tmp-slot pre-live
- call-slots)))
- (result-vars (vector-ref defv (label->idx kargs)))
- (value-slots (map (cut + proc-slot 1 <>)
- (iota (length result-vars))))
- ;; Shuffle the first result down to the lowest slot, and
- ;; leave any remaining results where they are. This
- ;; strikes a balance between avoiding shuffling,
- ;; especially for unused extra values, and avoiding
- ;; frame size growth due to sparse locals.
- (result-live (match (cons result-vars value-slots)
- ((() . ()) post-live)
- (((var . vars) . (slot . slots))
- (fold allocate!
- (allocate! var #f post-live)
- vars slots))))
- (result-slots (map (cut vector-ref slots <>) result-vars))
- ;; Filter out unused results.
- (value-slots (filter-map (lambda (val result) (and result val))
- value-slots result-slots))
- (result-slots (filter (lambda (x) x) result-slots))
- (result-moves (parallel-move value-slots
- result-slots
- (compute-tmp-slot result-live
- value-slots)))
- (dead-slot-map (logand (1- (ash 1 (- proc-slot 2)))
- (lognot post-live))))
- (bump-nlocals! (+ proc-slot (length uses)))
- (hashq-set! call-allocations label
- (make-call-allocation proc-slot arg-moves
dead-slot-map))
- (hashq-set! call-allocations k
- (make-call-allocation proc-slot result-moves #f))))))
-
- (define (allocate-values label k uses pre-live post-live)
- (match (lookup-cont k dfg)
- (($ $ktail)
- (let* ((src-slots (map (cut vector-ref slots <>) uses))
- (tail-nlocals (1+ (length uses)))
- (dst-slots (cdr (iota tail-nlocals)))
- (moves (parallel-move src-slots dst-slots
- (compute-tmp-slot pre-live dst-slots))))
- (bump-nlocals! tail-nlocals)
- (hashq-set! call-allocations label
- (make-call-allocation #f moves #f))))
- (($ $kargs (_) (_))
- ;; When there is only one value in play, we allow the dst to be
- ;; hinted (see scan-for-hints). If the src doesn't have a
- ;; slot, then the actual slot for the dst would end up being
- ;; decided by the call that uses it. Because we don't know the
- ;; slot, we can't really compute the parallel moves in that
- ;; case, so just bail and rely on the bytecode emitter to
- ;; handle the one-value case specially.
- (match (cons uses (vector-ref defv (label->idx k)))
- (((src) . (dst))
- (allocate! dst (vector-ref slots src) post-live))))
- (($ $kargs)
- (let* ((src-slots (map (cut vector-ref slots <>) uses))
- (dst-vars (vector-ref defv (label->idx k)))
- (result-live (fold allocate! post-live dst-vars src-slots))
- (dst-slots (map (cut vector-ref slots <>) dst-vars))
- (moves (parallel-move src-slots dst-slots
- (compute-tmp-slot (logior pre-live
result-live)
- '()))))
- (hashq-set! call-allocations label
- (make-call-allocation #f moves #f))))))
-
- (define (allocate-prompt label k handler)
- (match (lookup-cont handler dfg)
- (($ $kreceive arity kargs)
- (let* ((handler-live (recompute-live-slots handler))
- (proc-slot (compute-prompt-handler-proc-slot handler-live))
- (result-vars (vector-ref defv (label->idx kargs)))
- (value-slots (map (cut + proc-slot 1 <>)
- (iota (length result-vars))))
- (result-live (fold allocate!
- handler-live result-vars value-slots))
- (result-slots (map (cut vector-ref slots <>) result-vars))
- ;; Filter out unused results.
- (value-slots (filter-map (lambda (val result) (and result val))
- value-slots result-slots))
- (result-slots (filter (lambda (x) x) result-slots))
- (moves (parallel-move value-slots
- result-slots
- (compute-tmp-slot result-live
- value-slots))))
- (bump-nlocals! (+ proc-slot 1 (length result-vars)))
- (hashq-set! call-allocations handler
- (make-call-allocation proc-slot moves #f))))))
-
- (define (allocate-defs! n live)
- (fold (cut allocate! <> #f <>) live (vector-ref defv n)))
-
- ;; This traversal will visit definitions before uses, as
- ;; definitions dominate uses and a block's dominator will appear
- ;; before it, in reverse post-order.
- (define (visit-clause n live)
- (let lp ((n n) (live (recompute-live-slots (idx->label n))))
- (define (kill-dead live vars-by-label-idx pred)
- (fold (lambda (v live)
- (let ((slot (vector-ref slots v)))
- (if (and slot (pred n v dfa))
- (kill-dead-slot slot live)
- live)))
- live
- (vector-ref vars-by-label-idx n)))
- (define (kill-dead-defs live)
- (kill-dead live defv dead-after-def?))
- (define (kill-dead-uses live)
- (kill-dead live usev dead-after-use?))
- (if (= n label-count)
- n
- (let* ((label (idx->label n))
- (live (if (control-point? label dfg)
- (recompute-live-slots label)
- live))
- (live (kill-dead-defs (allocate-defs! n live)))
- (post-live (kill-dead-uses live)))
- ;; LIVE are the live slots coming into the term.
- ;; POST-LIVE is the subset that is still live after the
- ;; term uses its inputs.
- (match (lookup-cont (idx->label n) dfg)
- (($ $kclause) n)
- (($ $kargs names syms body)
- (define (compute-k-live k)
- (match (lookup-predecessors k dfg)
- ((_) post-live)
- (_ (recompute-live-slots k))))
- (let ((uses (vector-ref usev n)))
- (match (find-call body)
- (($ $continue k src (or ($ $call) ($ $callk)))
- (allocate-call label k uses live (compute-k-live k)))
- (($ $continue k src ($ $primcall)) #t)
- (($ $continue k src ($ $values))
- (allocate-values label k uses live (compute-k-live k)))
- (($ $continue k src ($ $prompt escape? tag handler))
- (allocate-prompt label k handler))
- (_ #f)))
- (lp (1+ n) post-live))
- ((or ($ $kreceive) ($ $ktail))
- (lp (1+ n) post-live)))))))
-
- (define (visit-entry)
- (define (visit-clauses n live)
- (unless (eqv? live (add-live-slot 0 (empty-live-slots)))
- (error "Unexpected clause live set"))
- (set! nlocals 1)
- (match (lookup-cont (idx->label n) dfg)
- (($ $kclause arity ($ $cont kbody ($ $kargs names)) alternate)
- (unless (eq? (idx->label (1+ n)) kbody)
- (error "Unexpected label order"))
- (let* ((nargs (length names))
- (next (visit-clause (1+ n)
- (fold allocate! live
- (vector-ref defv (1+ n))
- (cdr (iota (1+ nargs)))))))
- (hashq-set! nlocals-table (idx->label n) nlocals)
- (when (< next label-count)
- (match alternate
- (($ $cont kalt)
- (unless (eq? kalt (idx->label next))
- (error "Unexpected clause order"))))
- (visit-clauses next live))))))
- (match (lookup-cont (idx->label 0) dfg)
- (($ $kfun src meta self)
- (visit-clauses 1 (allocate-defs! 0 (empty-live-slots))))))
-
- (compute-constants!)
- (compute-uses-and-defs!)
- (compute-unused-results!)
- (compute-needs-hint!)
- (visit-entry)
-
- (make-allocation dfa slots
- has-constv constant-values
- call-allocations
- nlocals-table)))
diff --git a/module/language/cps/spec.scm b/module/language/cps/spec.scm
deleted file mode 100644
index f1255af..0000000
--- a/module/language/cps/spec.scm
+++ /dev/null
@@ -1,37 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Code:
-
-(define-module (language cps spec)
- #:use-module (system base language)
- #:use-module (language cps)
- #:use-module (language cps compile-bytecode)
- #:export (cps))
-
-(define* (write-cps exp #:optional (port (current-output-port)))
- (write (unparse-cps exp) port))
-
-(define-language cps
- #:title "CPS Intermediate Language"
- #:reader (lambda (port env) (read port))
- #:printer write-cps
- #:parser parse-cps
- #:compilers `((bytecode . ,compile-bytecode))
- #:for-humans? #f
- )
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
deleted file mode 100644
index 6c23107..0000000
--- a/module/language/cps/verify.scm
+++ /dev/null
@@ -1,195 +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:
-;;;
-;;;
-;;; Code:
-
-(define-module (language cps verify)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-26)
- #:use-module (language cps)
- #:export (verify-cps))
-
-(define (verify-cps fun)
- (define seen-labels (make-hash-table))
- (define seen-vars (make-hash-table))
-
- (define (add sym seen env)
- (when (hashq-ref seen sym)
- (error "duplicate gensym" sym))
- (hashq-set! seen sym #t)
- (cons sym env))
-
- (define (add-env new seen env)
- (if (null? new)
- env
- (add-env (cdr new) seen (add (car new) seen env))))
-
- (define (add-vars new env)
- (unless (and-map exact-integer? new)
- (error "bad vars" new))
- (add-env new seen-vars env))
-
- (define (add-labels new env)
- (unless (and-map exact-integer? new)
- (error "bad labels" new))
- (add-env new seen-labels env))
-
- (define (check-ref sym seen env)
- (cond
- ((not (hashq-ref seen sym))
- (error "unbound lexical" sym))
- ((not (memq sym env))
- (error "displaced lexical" sym))))
-
- (define (check-label sym env)
- (check-ref sym seen-labels env))
-
- (define (check-var sym env)
- (check-ref sym seen-vars env))
-
- (define (check-src src)
- (if (and src (not (and (list? src) (and-map pair? src)
- (and-map symbol? (map car src)))))
- (error "bad src")))
-
- (define (visit-cont-body cont k-env v-env)
- (match cont
- (($ $kreceive ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f)
k)
- (check-label k k-env))
- (($ $kargs (name ...) (sym ...) body)
- (unless (= (length name) (length sym))
- (error "name and sym lengths don't match" name sym))
- (visit-term body k-env (add-vars sym v-env)))
- (_
- ;; $kclause, $kfun, and $ktail are only ever seen in $fun.
- (error "unexpected cont body" cont))))
-
- (define (visit-clause clause k-env v-env)
- (match clause
- (($ $cont kclause
- ($ $kclause
- ($ $arity
- ((? symbol? req) ...)
- ((? symbol? opt) ...)
- (and rest (or #f (? symbol?)))
- (((? keyword? kw) (? symbol? kwname) kwsym) ...)
- (or #f #t))
- ($ $cont kbody (and body ($ $kargs names syms _)))
- alternate))
- (for-each (lambda (sym)
- (unless (memq sym syms)
- (error "bad keyword sym" sym)))
- kwsym)
- ;; FIXME: It is technically possible for kw syms to alias other
- ;; syms.
- (unless (equal? (append req opt (if rest (list rest) '()) kwname)
- names)
- (error "clause body names do not match arity names" exp))
- (let ((k-env (add-labels (list kclause kbody) k-env)))
- (visit-cont-body body k-env v-env))
- (when alternate
- (visit-clause alternate k-env v-env)))
- (_
- (error "unexpected clause" clause))))
-
- (define (visit-entry entry k-env v-env)
- (match entry
- (($ $cont kbody
- ($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause))
- (when (and meta (not (and (list? meta) (and-map pair? meta))))
- (error "meta should be alist" meta))
- (check-src src)
- ;; Reset the continuation environment, because Guile's
- ;; continuations are local.
- (let ((v-env (add-vars (list self) v-env))
- (k-env (add-labels (list ktail) '())))
- (when clause
- (visit-clause clause k-env v-env))))
- (_ (error "unexpected $kfun" entry))))
-
- (define (visit-fun fun k-env v-env)
- (match fun
- (($ $fun entry)
- (visit-entry entry '() v-env))
- (_
- (error "unexpected $fun" fun))))
-
- (define (visit-expression exp k-env v-env)
- (match exp
- (($ $const val)
- #t)
- (($ $prim (? symbol? name))
- #t)
- (($ $closure kfun n)
- #t)
- (($ $fun)
- (visit-fun exp k-env v-env))
- (($ $rec (name ...) (sym ...) (fun ...))
- (unless (= (length name) (length sym) (length fun))
- (error "letrec syms, names, and funs not same length" term))
- ;; FIXME: syms added in two places (here in $rec versus also in
- ;; target $kargs)
- (let ((v-env (add-vars sym v-env)))
- (for-each (cut visit-fun <> k-env v-env) fun)))
- (($ $call proc (arg ...))
- (check-var proc v-env)
- (for-each (cut check-var <> v-env) arg))
- (($ $callk k* proc (arg ...))
- ;; We don't check that k* is in scope; it's actually inside some
- ;; other function, probably. We rely on the transformation that
- ;; introduces the $callk to be correct, and the linker to resolve
- ;; the reference.
- (check-var proc v-env)
- (for-each (cut check-var <> v-env) arg))
- (($ $branch kt ($ $primcall (? symbol? name) (arg ...)))
- (check-var kt k-env)
- (for-each (cut check-var <> v-env) arg))
- (($ $branch kt ($ $values (arg ...)))
- (check-var kt k-env)
- (for-each (cut check-var <> v-env) arg))
- (($ $primcall (? symbol? name) (arg ...))
- (for-each (cut check-var <> v-env) arg))
- (($ $values (arg ...))
- (for-each (cut check-var <> v-env) arg))
- (($ $prompt escape? tag handler)
- (unless (boolean? escape?) (error "escape? should be boolean" escape?))
- (check-var tag v-env)
- (check-label handler k-env))
- (_
- (error "unexpected expression" exp))))
-
- (define (visit-term term k-env v-env)
- (match term
- (($ $letk (($ $cont k cont) ...) body)
- (let ((k-env (add-labels k k-env)))
- (for-each (cut visit-cont-body <> k-env v-env) cont)
- (visit-term body k-env v-env)))
-
- (($ $continue k src exp)
- (check-label k k-env)
- (check-src src)
- (visit-expression exp k-env v-env))
-
- (_
- (error "unexpected term" term))))
-
- (visit-entry fun '() '())
- fun)
diff --git a/module/language/cps2/compile-cps.scm
b/module/language/cps2/compile-cps.scm
deleted file mode 100644
index ee6e3d5..0000000
--- a/module/language/cps2/compile-cps.scm
+++ /dev/null
@@ -1,129 +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:
-;;;
-;;; 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 closure-conversion)
- #:use-module (language cps2 optimize)
- #:use-module (language cps2 reify-primitives)
- #: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 #:optional (kfun 0))
- (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 kfun))
-
-(define (conts->fun* conts)
- (cps:build-cps-term
- (cps:$program
- ,(intmap-fold-right (lambda (label cont out)
- (match cont
- (($ $kfun)
- (cons (conts->fun conts label) out))
- (_ out)))
- conts
- '()))))
-
-(define (kw-arg-ref args kw default)
- (match (memq kw args)
- ((_ val . _) val)
- (_ default)))
-
-(define (compile-cps exp env opts)
- ;; Use set! to save memory at bootstrap-time. (The interpreter holds
- ;; onto all free variables locally bound in a function, so if we used
- ;; let*, we'd hold onto earlier copies of the term.)
- (set! exp (optimize-higher-order-cps exp opts))
- (set! exp (convert-closures exp))
- (set! exp (optimize-first-order-cps exp opts))
- (set! exp (reify-primitives exp))
- (set! exp (renumber exp))
- (values (conts->fun* exp) env env))
- [Guile-commits] 05/13: More slot-allocation simplification, (continued)
- [Guile-commits] 05/13: More slot-allocation simplification, Andy Wingo, 2015/07/22
- [Guile-commits] 03/13: Utils refactors, Andy Wingo, 2015/07/22
- [Guile-commits] 07/13: Fix bad return shuffles for multiply-used $kreceive conts, Andy Wingo, 2015/07/22
- [Guile-commits] 01/13: Reify primitives in CPS2, Andy Wingo, 2015/07/22
- [Guile-commits] 09/13: Fix CPS2 compute-successors, Andy Wingo, 2015/07/22
- [Guile-commits] 06/13: Fix error printing some wrong-num-args backtraces, Andy Wingo, 2015/07/22
- [Guile-commits] 02/13: Add intset-prev and intset-fold-right, Andy Wingo, 2015/07/22
- [Guile-commits] 11/13: Compile CPS2 directly to bytecode, Andy Wingo, 2015/07/22
- [Guile-commits] 08/13: intset-intersect bugfix, Andy Wingo, 2015/07/22
- [Guile-commits] 10/13: Slot allocation and bytecode compilation from CPS2., Andy Wingo, 2015/07/22
- [Guile-commits] 12/13: Remove CPS1 language,
Andy Wingo <=
- [Guile-commits] 13/13: Rename CPS2 to CPS, Andy Wingo, 2015/07/22