mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

Remove CPS1 language

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2015-07-22 17:15:06 +02:00
parent 39777b11b3
commit 0d4c937722
9 changed files with 1 additions and 3379 deletions
Download patch file Download diff file Expand all files Collapse all files

10
module/Makefile.am
View file

@ -122,20 +122,12 @@ TREE_IL_LANG_SOURCES = \
language/tree-il/spec.scm language/tree-il/spec.scm
CPS_LANG_SOURCES = \ CPS_LANG_SOURCES = \
language/cps.scm \ language/cps/primitives.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
CPS2_LANG_SOURCES = \ CPS2_LANG_SOURCES = \
language/cps2.scm \ language/cps2.scm \
language/cps2/closure-conversion.scm \ language/cps2/closure-conversion.scm \
language/cps2/compile-bytecode.scm \ language/cps2/compile-bytecode.scm \
language/cps2/compile-cps.scm \
language/cps2/constructors.scm \ language/cps2/constructors.scm \
language/cps2/contification.scm \ language/cps2/contification.scm \
language/cps2/cse.scm \ language/cps2/cse.scm \

620
module/language/cps.scm
View file

@ -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))))

453
module/language/cps/compile-bytecode.scm
View file

@ -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)))

904
module/language/cps/dfg.scm
View file

@ -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 ~@y" 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)))

343
module/language/cps/renumber.scm
View file

@ -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))))

689
module/language/cps/slot-allocation.scm
View file

@ -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)))

37
module/language/cps/spec.scm
View file

@ -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
)

195
module/language/cps/verify.scm
View file

@ -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)

129
module/language/cps2/compile-cps.scm
View file

@ -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))