mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 21:40:33 +02:00
Remove CPS1 language
* module/language/cps.scm: * module/language/cps/compile-bytecode.scm: * module/language/cps/dfg.scm: * module/language/cps/renumber.scm: * module/language/cps/slot-allocation.scm: * module/language/cps/spec.scm: * module/language/cps/verify.scm: * module/language/cps2/compile-cps.scm: Delete. * module/Makefile.am: Remove deleted files.
This commit is contained in:
Andy Wingo
parent
39777b11b3
commit
0d4c937722
9 changed files with 1 additions and 3379 deletions
|
|
@ -122,20 +122,12 @@ TREE_IL_LANG_SOURCES = \
|
|||
language/tree-il/spec.scm
|
||||
|
||||
CPS_LANG_SOURCES = \
|
||||
language/cps.scm \
|
||||
language/cps/compile-bytecode.scm \
|
||||
language/cps/dfg.scm \
|
||||
language/cps/primitives.scm \
|
||||
language/cps/renumber.scm \
|
||||
language/cps/slot-allocation.scm \
|
||||
language/cps/spec.scm \
|
||||
language/cps/verify.scm
|
||||
language/cps/primitives.scm
|
||||
|
||||
CPS2_LANG_SOURCES = \
|
||||
language/cps2.scm \
|
||||
language/cps2/closure-conversion.scm \
|
||||
language/cps2/compile-bytecode.scm \
|
||||
language/cps2/compile-cps.scm \
|
||||
language/cps2/constructors.scm \
|
||||
language/cps2/contification.scm \
|
||||
language/cps2/cse.scm \
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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))))
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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
|
||||
)
|
||||
|
|
@ -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)
|
||||
|
|
@ -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))
|
||||
Loading…
Add table
Add a link
Reference in a new issue