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