summaryrefslogtreecommitdiff
path: root/module/language/cps/renumber.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/cps/renumber.scm')
-rw-r--r--module/language/cps/renumber.scm229
1 files changed, 229 insertions, 0 deletions
diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
new file mode 100644
index 000000000..2b4847926
--- /dev/null
+++ b/module/language/cps/renumber.scm
@@ -0,0 +1,229 @@
+;;; 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:
+;;;
+;;; 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 (srfi srfi-11)
+ #:use-module (language cps)
+ #:use-module (language cps utils)
+ #:use-module (language cps intset)
+ #:use-module (language cps intmap)
+ #:export (renumber))
+
+(define* (compute-tail-path-lengths conts kfun preds)
+ (define (add-lengths labels lengths length)
+ (intset-fold (lambda (label lengths)
+ (intmap-add! lengths label length))
+ labels
+ lengths))
+ (define (compute-next labels lengths)
+ (intset-fold (lambda (label labels)
+ (fold1 (lambda (pred labels)
+ (if (intmap-ref lengths pred (lambda (_) #f))
+ labels
+ (intset-add! labels pred)))
+ (intmap-ref preds label)
+ labels))
+ labels
+ empty-intset))
+ (define (visit labels lengths length)
+ (let ((lengths (add-lengths labels lengths length)))
+ (values (compute-next labels lengths) lengths (1+ length))))
+ (match (intmap-ref conts kfun)
+ (($ $kfun src meta self tail clause)
+ (worklist-fold visit (intset-add empty-intset tail) empty-intmap 0))))
+
+;; Topologically sort the continuation tree starting at k0, using
+;; reverse post-order numbering.
+(define (sort-labels-locally conts k0 path-lengths)
+ (define (visit-kf-first? kf kt)
+ ;; Visit the successor of a branch 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 ((kf-len (intmap-ref path-lengths kf (lambda (_) #f)))
+ (kt-len (intmap-ref path-lengths kt (lambda (_) #f))))
+ (if kt-len
+ (or (not kf-len) (< kf-len kt-len)
+ ;; If the path lengths are the same, preserve original
+ ;; order to avoid squirreliness.
+ (and (= kf-len kt-len) (< kt kf)))
+ (if kf-len #f (< kt kf)))))
+ (let ((order '())
+ (visited empty-intset))
+ (let visit ((k k0) (order '()) (visited empty-intset))
+ (define (visit2 k0 k1 order visited)
+ (let-values (((order visited) (visit k0 order visited)))
+ (visit k1 order visited)))
+ (if (intset-ref visited k)
+ (values order visited)
+ (let ((visited (intset-add visited k)))
+ (call-with-values
+ (lambda ()
+ (match (intmap-ref conts k)
+ (($ $kargs names syms term)
+ (match term
+ (($ $continue k)
+ (visit k order visited))
+ (($ $branch kf kt)
+ (if (visit-kf-first? kf kt)
+ (visit2 kf kt order visited)
+ (visit2 kt kf order visited)))
+ (($ $prompt k kh)
+ (visit2 k kh order visited))
+ (($ $throw)
+ (values order visited))))
+ (($ $kreceive arity k) (visit k order visited))
+ (($ $kclause arity kbody kalt)
+ (if kalt
+ (visit2 kalt kbody order visited)
+ (visit kbody order visited)))
+ (($ $kfun src meta self tail clause)
+ (if clause
+ (visit2 tail clause order visited)
+ (visit tail order visited)))
+ (($ $ktail) (values order visited))))
+ (lambda (order visited)
+ ;; Add k to the reverse post-order.
+ (values (cons k order) visited))))))))
+
+(define (compute-renaming conts kfun)
+ ;; labels := old -> new
+ ;; vars := old -> new
+ (define *next-label* -1)
+ (define *next-var* -1)
+ (define (rename-label label labels)
+ (set! *next-label* (1+ *next-label*))
+ (intmap-add! labels label *next-label*))
+ (define (rename-var sym vars)
+ (set! *next-var* (1+ *next-var*))
+ (intmap-add! vars sym *next-var*))
+ (define (rename label labels vars)
+ (values (rename-label label labels)
+ (match (intmap-ref conts label)
+ (($ $kargs names syms exp)
+ (fold1 rename-var syms vars))
+ (($ $kfun src meta self tail clause)
+ (rename-var self vars))
+ (_ vars))))
+ (define (maybe-visit-fun kfun labels vars)
+ (if (intmap-ref labels kfun (lambda (_) #f))
+ (values labels vars)
+ (visit-fun kfun labels vars)))
+ (define (visit-nested-funs k labels vars)
+ (match (intmap-ref conts k)
+ (($ $kargs names syms ($ $continue k src ($ $fun kfun)))
+ (visit-fun kfun labels vars))
+ (($ $kargs names syms ($ $continue k src ($ $rec names* syms*
+ (($ $fun kfun) ...))))
+ (fold2 visit-fun kfun labels vars))
+ (($ $kargs names syms ($ $continue k src ($ $const-fun kfun)))
+ ;; Closures with zero free vars get copy-propagated so it's
+ ;; possible to already have visited them.
+ (maybe-visit-fun kfun labels vars))
+ (($ $kargs names syms ($ $continue k src ($ $code kfun)))
+ (maybe-visit-fun kfun labels vars))
+ (($ $kargs names syms ($ $continue k src ($ $callk kfun)))
+ ;; Well-known functions never have a $const-fun created for them
+ ;; and are only referenced by their $callk call sites.
+ (maybe-visit-fun kfun labels vars))
+ (_ (values labels vars))))
+ (define (visit-fun kfun labels vars)
+ (let* ((preds (compute-predecessors conts kfun))
+ (path-lengths (compute-tail-path-lengths conts kfun preds))
+ (order (sort-labels-locally conts kfun path-lengths)))
+ ;; First rename locally, then recurse on nested functions.
+ (let-values (((labels vars) (fold2 rename order labels vars)))
+ (fold2 visit-nested-funs order labels vars))))
+ (let-values (((labels vars) (visit-fun kfun empty-intmap empty-intmap)))
+ (values (persistent-intmap labels) (persistent-intmap vars))))
+
+(define* (renumber conts #:optional (kfun 0))
+ (let-values (((label-map var-map) (compute-renaming conts kfun)))
+ (define (rename-label label) (intmap-ref label-map label))
+ (define (rename-var var) (intmap-ref var-map var))
+ (define (rename-exp exp)
+ (rewrite-exp exp
+ ((or ($ $const) ($ $prim)) ,exp)
+ (($ $const-fun k)
+ ($const-fun (rename-label k)))
+ (($ $code k)
+ ($code (rename-label k)))
+ (($ $fun body)
+ ($fun (rename-label body)))
+ (($ $rec names vars funs)
+ ($rec names (map rename-var vars) (map rename-exp funs)))
+ (($ $values args)
+ ($values ,(map rename-var args)))
+ (($ $call proc args)
+ ($call (rename-var proc) ,(map rename-var args)))
+ (($ $callk k proc args)
+ ($callk (rename-label k) (rename-var proc) ,(map rename-var args)))
+ (($ $primcall name param args)
+ ($primcall name param ,(map rename-var args)))))
+ (define (rename-arity arity)
+ (match arity
+ (($ $arity req opt rest () aok?)
+ arity)
+ (($ $arity req opt rest kw aok?)
+ (match kw
+ (() arity)
+ (((kw kw-name kw-var) ...)
+ (let ((kw (map list kw kw-name (map rename-var kw-var))))
+ (make-$arity req opt rest kw aok?)))))))
+ (persistent-intmap
+ (intmap-fold
+ (lambda (old-k new-k out)
+ (intmap-add!
+ out
+ new-k
+ (rewrite-cont (intmap-ref conts old-k)
+ (($ $kargs names syms term)
+ ($kargs names (map rename-var syms)
+ ,(rewrite-term term
+ (($ $continue k src exp)
+ ($continue (rename-label k) src ,(rename-exp exp)))
+ (($ $branch kf kt src op param args)
+ ($branch (rename-label kf) (rename-label kt) src
+ op param ,(map rename-var args)))
+ (($ $prompt k kh src escape? tag)
+ ($prompt (rename-label k) (rename-label kh) src
+ escape? (rename-var tag)))
+ (($ $throw src op param args)
+ ($throw src op param ,(map rename-var args))))))
+ (($ $kreceive ($ $arity req () rest () #f) k)
+ ($kreceive req rest (rename-label k)))
+ (($ $ktail)
+ ($ktail))
+ (($ $kfun src meta self tail clause)
+ ($kfun src meta (rename-var self) (rename-label tail)
+ (and clause (rename-label clause))))
+ (($ $kclause arity body alternate)
+ ($kclause ,(rename-arity arity) (rename-label body)
+ (and alternate (rename-label alternate)))))))
+ label-map
+ empty-intmap))))