summaryrefslogtreecommitdiff
path: root/module/language/cps/contification.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/cps/contification.scm')
-rw-r--r--module/language/cps/contification.scm498
1 files changed, 498 insertions, 0 deletions
diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm
new file mode 100644
index 000000000..43a58a1e6
--- /dev/null
+++ b/module/language/cps/contification.scm
@@ -0,0 +1,498 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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:
+;;;
+;;; Contification is a pass that turns $fun instances into $cont
+;;; instances if all calls to the $fun return to the same continuation.
+;;; This is a more rigorous variant of our old "fixpoint labels
+;;; allocation" optimization.
+;;;
+;;; See Kennedy's "Compiling with Continuations, Continued", and Fluet
+;;; and Weeks's "Contification using Dominators".
+;;;
+;;; Code:
+
+(define-module (language cps contification)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-11)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (language cps)
+ #:use-module (language cps renumber)
+ #:use-module (language cps utils)
+ #:use-module (language cps intmap)
+ #:use-module (language cps intset)
+ #:use-module (language cps with-cps)
+ #:export (contify))
+
+(define (compute-singly-referenced-labels conts)
+ "Compute the set of labels in CONTS that have exactly one
+predecessor."
+ (define (add-ref label cont single multiple)
+ (define (ref k single multiple)
+ (if (intset-ref single k)
+ (values single (intset-add! multiple k))
+ (values (intset-add! single k) multiple)))
+ (define (ref0) (values single multiple))
+ (define (ref1 k) (ref k single multiple))
+ (define (ref2 k k*)
+ (if k*
+ (let-values (((single multiple) (ref k single multiple)))
+ (ref k* single multiple))
+ (ref1 k)))
+ (match cont
+ (($ $kreceive arity k) (ref1 k))
+ (($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
+ (($ $ktail) (ref0))
+ (($ $kclause arity kbody kalt) (ref2 kbody kalt))
+ (($ $kargs names syms ($ $continue k)) (ref1 k))
+ (($ $kargs names syms ($ $branch kf kt)) (ref2 kf kt))
+ (($ $kargs names syms ($ $prompt k kh)) (ref2 k kh))
+ (($ $kargs names syms ($ $throw)) (ref0))))
+ (let*-values (((single multiple) (values empty-intset empty-intset))
+ ((single multiple) (intmap-fold add-ref conts single multiple)))
+ (intset-subtract (persistent-intset single)
+ (persistent-intset multiple))))
+
+(define (compute-functions conts)
+ "Compute a map from $kfun label to bound variable names for all
+functions in CONTS. Functions have two bound variable names: their self
+binding, and the name they are given in their continuation. If their
+continuation has more than one predecessor, then the bound variable name
+doesn't uniquely identify the function, so we exclude that function from
+the set."
+ (define (function-self label)
+ (match (intmap-ref conts label)
+ (($ $kfun src meta self) self)))
+ (let ((single (compute-singly-referenced-labels conts)))
+ (intmap-fold (lambda (label cont functions)
+ (match cont
+ (($ $kargs _ _ ($ $continue k src ($ $fun kfun)))
+ (if (intset-ref single k)
+ (match (intmap-ref conts k)
+ (($ $kargs (name) (var))
+ (intmap-add functions kfun
+ (intset var (function-self kfun)))))
+ functions))
+ (($ $kargs _ _ ($ $continue k src
+ ($ $rec _ vars (($ $fun kfuns) ...))))
+ (if (intset-ref single k)
+ (fold (lambda (var kfun functions)
+ (intmap-add functions kfun
+ (intset var (function-self kfun))))
+ functions vars kfuns)
+ functions))
+ (_ functions)))
+ conts
+ empty-intmap)))
+
+(define (compute-arities conts functions)
+ "Given the map FUNCTIONS whose keys are $kfun labels, return a map
+from label to arities."
+ (define (clause-arities clause)
+ (if clause
+ (match (intmap-ref conts clause)
+ (($ $kclause arity body alt)
+ (cons arity (clause-arities alt))))
+ '()))
+ (intmap-map (lambda (label vars)
+ (match (intmap-ref conts label)
+ (($ $kfun src meta self tail clause)
+ (clause-arities clause))))
+ functions))
+
+;; For now, we don't contify functions with optional, keyword, or rest
+;; arguments.
+(define (contifiable-arity? arity)
+ (match arity
+ (($ $arity req () #f () aok?)
+ #t)
+ (_
+ #f)))
+
+(define (arity-matches? arity nargs)
+ (match arity
+ (($ $arity req () #f () aok?)
+ (= nargs (length req)))
+ (_
+ #f)))
+
+(define (compute-contification-candidates conts)
+ "Compute and return a label -> (variable ...) map describing all
+functions with known uses that are only ever used as the operator of a
+$call, and are always called with a compatible arity."
+ (let* ((functions (compute-functions conts))
+ (vars (intmap-fold (lambda (label vars out)
+ (intset-fold (lambda (var out)
+ (intmap-add out var label))
+ vars out))
+ functions
+ empty-intmap))
+ (arities (compute-arities conts functions)))
+ (define (restrict-arity functions proc nargs)
+ (match (intmap-ref vars proc (lambda (_) #f))
+ (#f functions)
+ (label
+ (let lp ((arities (intmap-ref arities label)))
+ (match arities
+ (() (intmap-remove functions label))
+ ((arity . arities)
+ (cond
+ ((not (contifiable-arity? arity)) (lp '()))
+ ((arity-matches? arity nargs) functions)
+ (else (lp arities)))))))))
+ (define (visit-cont label cont functions)
+ (define (exclude-var functions var)
+ (match (intmap-ref vars var (lambda (_) #f))
+ (#f functions)
+ (label (intmap-remove functions label))))
+ (define (exclude-vars functions vars)
+ (match vars
+ (() functions)
+ ((var . vars)
+ (exclude-vars (exclude-var functions var) vars))))
+ (match cont
+ (($ $kargs _ _ ($ $continue _ _ exp))
+ (match exp
+ ((or ($ $const) ($ $prim) ($ $const-fun) ($ $code) ($ $fun) ($ $rec))
+ functions)
+ (($ $values args)
+ (exclude-vars functions args))
+ (($ $call proc args)
+ (let ((functions (exclude-vars functions args)))
+ ;; Note that this contification algorithm is happy to
+ ;; contify the `lp' in this example into a shared tail
+ ;; between clauses:
+ ;;
+ ;; (letrec ((lp (lambda () (lp))))
+ ;; (case-lambda
+ ;; ((a) (lp))
+ ;; ((a b) (lp))))
+ ;;
+ ;; This can cause cross-clause jumps. The rest of the
+ ;; compiler handles this fine though, so we allow it.
+ (restrict-arity functions proc (length args))))
+ (($ $callk k proc args)
+ (exclude-vars functions (cons proc args)))
+ (($ $primcall name param args)
+ (exclude-vars functions args))))
+ (($ $kargs _ _ ($ $branch kf kt src op param args))
+ (exclude-vars functions args))
+ (($ $kargs _ _ ($ $prompt k kh src escape? tag))
+ (exclude-var functions tag))
+ (($ $kargs _ _ ($ $throw src op param args))
+ (exclude-vars functions args))
+ (_ functions)))
+ (intmap-fold visit-cont conts functions)))
+
+(define (compute-call-graph conts labels vars)
+ "Given the set of contifiable functions LABELS and associated bound
+variables VARS, compute and return two values: a map
+LABEL->LABEL... indicating the contifiable functions called by a
+function, and a map LABEL->LABEL... indicating the return continuations
+for a function. The first return value also has an entry
+0->LABEL... indicating all contifiable functions called by
+non-contifiable functions. We assume that 0 is not in the contifiable
+function set."
+ (let ((bodies
+ ;; label -> fun-label for all labels in bodies of contifiable
+ ;; functions
+ (intset-fold (lambda (fun-label bodies)
+ (intset-fold (lambda (label bodies)
+ (intmap-add bodies label fun-label))
+ (compute-function-body conts fun-label)
+ bodies))
+ labels
+ empty-intmap)))
+ (when (intset-ref labels 0)
+ (error "internal error: label 0 should not be contifiable"))
+ (intmap-fold
+ (lambda (label cont calls returns)
+ (match cont
+ (($ $kargs _ _ ($ $continue k src ($ $call proc)))
+ (match (intmap-ref vars proc (lambda (_) #f))
+ (#f (values calls returns))
+ (callee
+ (let ((caller (intmap-ref bodies label (lambda (_) 0))))
+ (values (intmap-add calls caller callee intset-add)
+ (intmap-add returns callee k intset-add))))))
+ (_ (values calls returns))))
+ conts
+ (intset->intmap (lambda (label) empty-intset) (intset-add labels 0))
+ (intset->intmap (lambda (label) empty-intset) labels))))
+
+(define (tail-label conts label)
+ (match (intmap-ref conts label)
+ (($ $kfun src meta self tail body)
+ tail)))
+
+(define (compute-return-labels labels tails returns return-substs)
+ (define (subst k)
+ (match (intmap-ref return-substs k (lambda (_) #f))
+ (#f k)
+ (k (subst k))))
+ ;; Compute all return labels, then subtract tail labels of the
+ ;; functions in question.
+ (intset-subtract
+ ;; Return labels for all calls to these labels.
+ (intset-fold (lambda (label out)
+ (intset-fold (lambda (k out)
+ (intset-add out (subst k)))
+ (intmap-ref returns label)
+ out))
+ labels
+ empty-intset)
+ (intset-fold (lambda (label out)
+ (intset-add out (intmap-ref tails label)))
+ labels
+ empty-intset)))
+
+(define (intmap->intset map)
+ (define (add-key label cont labels)
+ (intset-add labels label))
+ (intmap-fold add-key map empty-intset))
+
+(define (filter-contifiable contified groups)
+ (intmap-fold (lambda (id labels groups)
+ (let ((labels (intset-subtract labels contified)))
+ (if (eq? empty-intset labels)
+ groups
+ (intmap-add groups id labels))))
+ groups
+ empty-intmap))
+
+(define (trivial-set set)
+ (let ((first (intset-next set)))
+ (and first
+ (not (intset-next set (1+ first)))
+ first)))
+
+(define (compute-contification conts)
+ (let*-values
+ (;; label -> (var ...)
+ ((candidates) (compute-contification-candidates conts))
+ ((labels) (intmap->intset candidates))
+ ;; var -> label
+ ((vars) (intmap-fold (lambda (label vars out)
+ (intset-fold (lambda (var out)
+ (intmap-add out var label))
+ vars out))
+ candidates
+ empty-intmap))
+ ;; caller-label -> callee-label..., callee-label -> return-label...
+ ((calls returns) (compute-call-graph conts labels vars))
+ ;; callee-label -> tail-label
+ ((tails) (intset-fold
+ (lambda (label tails)
+ (intmap-add tails label (tail-label conts label)))
+ labels
+ empty-intmap))
+ ;; Strongly connected components, allowing us to contify mutually
+ ;; tail-recursive functions. Since `compute-call-graph' added on
+ ;; a synthetic 0->LABEL... entry for contifiable functions called
+ ;; by non-contifiable functions, we need to remove that entry
+ ;; from the partition. It will be in its own component, as it
+ ;; has no predecessors.
+ ;;
+ ;; id -> label...
+ ((groups) (intmap-remove
+ (compute-strongly-connected-components calls 0)
+ 0)))
+ ;; todo: thread groups through contification
+ (define (attempt-contification labels contified return-substs)
+ (let ((returns (compute-return-labels labels tails returns
+ return-substs)))
+ (cond
+ ((trivial-set returns)
+ => (lambda (k)
+ ;; Success!
+ (values (intset-union contified labels)
+ (intset-fold (lambda (label return-substs)
+ (let ((tail (intmap-ref tails label)))
+ (intmap-add return-substs tail k)))
+ labels return-substs))))
+ ((trivial-set labels)
+ ;; Single-label SCC failed to contify.
+ (values contified return-substs))
+ (else
+ ;; Multi-label SCC failed to contify. Try instead to contify
+ ;; each one.
+ (intset-fold
+ (lambda (label contified return-substs)
+ (let ((labels (intset-add empty-intset label)))
+ (attempt-contification labels contified return-substs)))
+ labels contified return-substs)))))
+ (call-with-values
+ (lambda ()
+ (fixpoint
+ (lambda (contified return-substs)
+ (intmap-fold
+ (lambda (id group contified return-substs)
+ (attempt-contification group contified return-substs))
+ (filter-contifiable contified groups)
+ contified
+ return-substs))
+ empty-intset
+ empty-intmap))
+ (lambda (contified return-substs)
+ (values (intset-fold (lambda (label call-substs)
+ (intset-fold
+ (lambda (var call-substs)
+ (intmap-add call-substs var label))
+ (intmap-ref candidates label)
+ call-substs))
+ contified
+ empty-intmap)
+ return-substs)))))
+
+(define (apply-contification conts call-substs return-substs)
+ (define (call-subst proc)
+ (intmap-ref call-substs proc (lambda (_) #f)))
+ (define (return-subst k)
+ (intmap-ref return-substs k (lambda (_) #f)))
+ (define (find-body kfun nargs)
+ (match (intmap-ref conts kfun)
+ (($ $kfun src meta self tail clause)
+ (let lp ((clause clause))
+ (match (intmap-ref conts clause)
+ (($ $kclause arity body alt)
+ (if (arity-matches? arity nargs)
+ body
+ (lp alt))))))))
+ (define (inline-return cps k* kargs src nreq rest vals)
+ (define (build-list cps k src vals)
+ (match vals
+ (()
+ (with-cps cps
+ (build-term ($continue k src ($const '())))))
+ ((v . vals)
+ (with-cps cps
+ (letv pair tail)
+ (letk kdone ($kargs () () ($continue k src ($values (pair)))))
+ (letk ktail
+ ($kargs () ()
+ ($continue kdone src
+ ($primcall 'scm-set!/immediate '(pair . 1) (pair tail)))))
+ (letk khead
+ ($kargs ('pair) (pair)
+ ($continue ktail src
+ ($primcall 'scm-set!/immediate '(pair . 0) (pair v)))))
+ (letk ktail
+ ($kargs ('tail) (tail)
+ ($continue khead src
+ ($primcall 'allocate-words/immediate '(pair . 2) ()))))
+ ($ (build-list ktail src vals))))))
+ (cond
+ ((and (not rest) (eqv? (length vals) nreq))
+ (with-cps cps
+ (build-term ($continue kargs src ($values vals)))))
+ ((and rest (<= nreq (length vals)))
+ (with-cps cps
+ (letv rest)
+ (letk krest ($kargs ('rest) (rest)
+ ($continue kargs src
+ ($values ,(append (list-head vals nreq)
+ (list rest))))))
+ ($ (build-list krest src (list-tail vals nreq)))))
+ (else
+ ;; Fallback case if values don't match.
+ (with-cps cps
+ (letv prim)
+ (letk kprim ($kargs ('prim) (prim)
+ ($continue k* src ($call prim vals))))
+ (build-term ($continue kprim src ($prim 'values)))))))
+ (define (continue cps k src exp)
+ (define (lookup-return-cont k)
+ (match (return-subst k)
+ (#f k)
+ (k (lookup-return-cont k))))
+ (let ((k* (lookup-return-cont k)))
+ (if (eq? k k*)
+ (with-cps cps (build-term ($continue k src ,exp)))
+ ;; We are contifying this return. It must be a call or a
+ ;; $values expression. k* will be either a $ktail or a
+ ;; $kreceive continuation.
+ (match (intmap-ref conts k*)
+ (($ $kreceive ($ $arity req () rest () #f) kargs)
+ (match exp
+ (($ $call)
+ (with-cps cps (build-term ($continue k* src ,exp))))
+ ;; We need to punch through the $kreceive; otherwise we'd
+ ;; have to rewrite as a call to the 'values primitive.
+ (($ $values vals)
+ (inline-return cps k* kargs src (length req) rest vals))))
+ (($ $ktail)
+ (with-cps cps (build-term ($continue k* src ,exp))))))))
+ (define (visit-exp cps k src exp)
+ (match exp
+ (($ $call proc args)
+ ;; If proc is contifiable, replace call with jump.
+ (match (call-subst proc)
+ (#f (continue cps k src exp))
+ (kfun
+ (let ((body (find-body kfun (length args))))
+ (with-cps cps
+ (build-term ($continue body src ($values args))))))))
+ (($ $fun kfun)
+ ;; If the function's tail continuation has been
+ ;; substituted, that means it has been contified.
+ (if (return-subst (tail-label conts kfun))
+ (continue cps k src (build-exp ($values ())))
+ (continue cps k src exp)))
+ (($ $rec names vars funs)
+ (match (filter (match-lambda ((n v f) (not (call-subst v))))
+ (map list names vars funs))
+ (() (continue cps k src (build-exp ($values ()))))
+ (((names vars funs) ...)
+ (continue cps k src (build-exp ($rec names vars funs))))))
+ (_ (continue cps k src exp))))
+ (define (visit-term cps term)
+ (match term
+ (($ $continue k src exp)
+ (visit-exp cps k src exp))
+ ((or ($ $branch) ($ $prompt) ($ $throw))
+ (with-cps cps term))))
+
+ ;; Renumbering is not strictly necessary but some passes may not be
+ ;; equipped to deal with stale $kfun nodes whose bodies have been
+ ;; wired into other functions.
+ (renumber
+ (with-fresh-name-state conts
+ (intmap-fold
+ (lambda (label cont out)
+ (match cont
+ (($ $kargs names vars term)
+ ;; Remove bindings for functions that have been contified.
+ (match (filter (match-lambda ((name var) (not (call-subst var))))
+ (map list names vars))
+ (((names vars) ...)
+ (with-cps out
+ (let$ term (visit-term term))
+ (setk label ($kargs names vars ,term))))))
+ (_ out)))
+ conts
+ conts))))
+
+(define (contify conts)
+ ;; FIXME: Renumbering isn't really needed but dead continuations may
+ ;; cause compute-singly-referenced-labels to spuriously mark some
+ ;; conts as irreducible. For now we punt and renumber so that there
+ ;; are only live conts.
+ (let ((conts (renumber conts)))
+ (let-values (((call-substs return-substs) (compute-contification conts)))
+ (apply-contification conts call-substs return-substs))))