From f296f54acda4a2da0a6209a10e5dc913ba95139f Mon Sep 17 00:00:00 2001
From: Eric Dobson <eric.n.dobson@gmail.com>
Date: Tue, 14 Jan 2014 23:41:53 -0800
Subject: [PATCH] Optimize away recursive contracts in more cases.

original commit: 74d79a50512835441709f6b61ddac246cb58ef6d
---
 .../static-contracts/optimize.rkt             | 25 ++++++++++++++++---
 .../static-contract-optimizer-tests.rkt       | 25 ++++++++++++++++++-
 2 files changed, 46 insertions(+), 4 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt
index 1b3e9d5f..a51eb393 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt
@@ -130,6 +130,18 @@
             (dict-set! new-table id #t))))
       (loop new-table)))
 
+  ;; Determine if the recursive name is referenced in the static contract
+  (define (unused? new-name sc)
+    (let/ec exit
+      (define (recur sc variance)
+        (match sc
+          [(recursive-sc-use (== new-name free-identifier=?))
+           (exit #f)]
+          [else
+            (sc-traverse sc recur)]))
+      (recur sc 'covariant)
+      #t))
+
   (define (trim sc variance)
     (match sc
       [(recursive-sc names values body)
@@ -143,9 +155,16 @@
        (define new-names (map first new-name-values))
        (define new-values (map (λ (v) (trim v 'covariant))
                                (map second new-name-values)))
-       (if (empty? new-names)
-           new-body
-           (recursive-sc new-names new-values new-body))]
+       (cond
+         [(empty? new-names) new-body]
+         [(and
+            (equal? (length new-names) 1)
+            (recursive-sc-use? new-body)
+            (free-identifier=? (first new-names) (recursive-sc-use-name new-body))
+            (unused? (first new-names) (first new-values)))
+          (first new-values)]
+         [else
+          (recursive-sc new-names new-values new-body)])]
       [else
         (sc-map sc trim)]))
   (trim sc 'covariant))
diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt
index 90ef9413..78022dd3 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt
@@ -2,7 +2,7 @@
 
 (require "test-utils.rkt"
          racket/list racket/format rackunit
-         (static-contracts instantiate optimize combinators)
+         (static-contracts instantiate optimize combinators structures)
          (for-syntax racket/base syntax/parse))
 
 (provide tests)
@@ -37,6 +37,10 @@
             (unless (equal? opt expected)
               (fail-check))))))))
 
+;; Ids with unique identity so that equals works
+(define foo-id #'foo)
+(define bar-id #'bar)
+
 (define tests
   (test-suite "Static Contract Optimizer Tests"
     ;; Lists
@@ -247,5 +251,24 @@
       #:pos (class/sc (list (member-spec 'field 'x list?/sc)) #f empty empty)
       #:neg (class/sc (list (member-spec 'field 'x list?/sc)) #f empty empty))
 
+    (check-optimize
+      (recursive-sc (list foo-id bar-id)
+                    (list (listof/sc (recursive-sc-use foo-id))
+                          (listof/sc (recursive-sc-use bar-id)))
+                    (recursive-sc-use foo-id))
+      #:pos (recursive-sc (list foo-id)
+                          (list (listof/sc (recursive-sc-use foo-id)))
+                          (recursive-sc-use foo-id))
+      #:neg (recursive-sc (list foo-id)
+                          (list (listof/sc (recursive-sc-use foo-id)))
+                          (recursive-sc-use foo-id)))
+
+    (check-optimize
+      (recursive-sc (list foo-id bar-id)
+                    (list (listof/sc any/sc )
+                          (listof/sc any/sc))
+                    (recursive-sc-use foo-id))
+      #:pos any/sc
+      #:neg list?/sc)
 
     ))