From ff1a02bd09fe8a58315b57a8c63f92c802a19972 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Wed, 3 Jun 2015 17:44:37 +0200
Subject: [PATCH] Port self-references pass to CPS2

* module/language/cps2/self-references.scm: New pass, ported from CPS.
* module/language/cps2/optimize.scm: Wire up the self references pass.
* module/Makefile.am: Add new file.
---
 module/Makefile.am                       |  1 +
 module/language/cps2/optimize.scm        |  3 +-
 module/language/cps2/self-references.scm | 79 ++++++++++++++++++++++++
 3 files changed, 82 insertions(+), 1 deletion(-)
 create mode 100644 module/language/cps2/self-references.scm

diff --git a/module/Makefile.am b/module/Makefile.am
index e7108aa3a..666175c17 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -160,6 +160,7 @@ CPS2_LANG_SOURCES =						\
   language/cps2/renumber.scm					\
   language/cps2/optimize.scm					\
   language/cps2/simplify.scm					\
+  language/cps2/self-references.scm				\
   language/cps2/spec.scm					\
   language/cps2/specialize-primcalls.scm			\
   language/cps2/type-fold.scm					\
diff --git a/module/language/cps2/optimize.scm b/module/language/cps2/optimize.scm
index 68b9523d1..ba8699fa4 100644
--- a/module/language/cps2/optimize.scm
+++ b/module/language/cps2/optimize.scm
@@ -31,6 +31,7 @@
   #:use-module (language cps2 elide-values)
   #:use-module (language cps2 prune-top-level-scopes)
   #:use-module (language cps2 prune-bailouts)
+  #:use-module (language cps2 self-references)
   #:use-module (language cps2 simplify)
   #:use-module (language cps2 specialize-primcalls)
   #:use-module (language cps2 type-fold)
@@ -70,7 +71,7 @@
   (run-pass! prune-bailouts #:prune-bailouts? #t)
   (run-pass! eliminate-common-subexpressions #:cse? #t)
   (run-pass! type-fold #:type-fold? #t)
-  ;; (run-pass! resolve-self-references #:resolve-self-references? #t)
+  (run-pass! resolve-self-references #:resolve-self-references? #t)
   ;; (run-pass! eliminate-dead-code #:eliminate-dead-code? #t)
   ;; (run-pass! simplify #:simplify? #t)
 
diff --git a/module/language/cps2/self-references.scm b/module/language/cps2/self-references.scm
new file mode 100644
index 000000000..20ac56f39
--- /dev/null
+++ b/module/language/cps2/self-references.scm
@@ -0,0 +1,79 @@
+;;; 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 pass that replaces free references to recursive functions with
+;;; bound references.
+;;;
+;;; Code:
+
+(define-module (language cps2 self-references)
+  #:use-module (ice-9 match)
+  #:use-module ((srfi srfi-1) #:select (fold))
+  #:use-module (language cps2)
+  #:use-module (language cps2 utils)
+  #:use-module (language cps intmap)
+  #:use-module (language cps intset)
+  #:export (resolve-self-references))
+
+(define* (resolve-self-references cps #:optional (label 0) (env empty-intmap))
+  (define (subst var)
+    (intmap-ref env var (lambda (var) var)))
+
+  (define (rename-exp label cps names vars k src exp)
+    (let ((exp (rewrite-exp exp
+                 ((or ($ $const) ($ $prim)) ,exp)
+                 (($ $call proc args)
+                  ($call (subst proc) ,(map subst args)))
+                 (($ $callk k proc args)
+                  ($callk k (subst proc) ,(map subst args)))
+                 (($ $primcall name args)
+                  ($primcall name ,(map subst args)))
+                 (($ $branch k ($ $values (arg)))
+                  ($branch k ($values ((subst arg)))))
+                 (($ $branch k ($ $primcall name args))
+                  ($branch k ($primcall name ,(map subst args))))
+                 (($ $values args)
+                  ($values ,(map subst args)))
+                 (($ $prompt escape? tag handler)
+                  ($prompt escape? (subst tag) handler)))))
+      (intmap-replace! cps label
+                       (build-cont
+                         ($kargs names vars ($continue k src ,exp))))))
+
+  (define (visit-exp cps label names vars k src exp)
+    (match exp
+      (($ $fun label)
+       (resolve-self-references cps label env))
+      (($ $rec names vars (($ $fun labels) ...))
+       (fold (lambda (label var cps)
+               (match (intmap-ref cps label)
+                 (($ $kfun src meta self)
+                  (resolve-self-references cps label
+                                           (intmap-add env var self)))))
+             cps labels vars))
+      (_ (rename-exp label cps names vars k src exp))))
+  
+  (intset-fold (lambda (label cps)
+                 (match (intmap-ref cps label)
+                   (($ $kargs names vars ($ $continue k src exp))
+                    (visit-exp cps label names vars k src exp))
+                   (_ cps)))
+               (compute-function-body cps label)
+               cps))