From 78e01006636e25a39152e094bf3af71c780942ad Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Mon, 13 Jun 2016 14:55:08 -0400
Subject: [PATCH] Improve contract inlining

TR sometimes inlines contracts instead of defining them
separately in order to cooperate with the contract system's
optimizations. In some cases, this caused TR to compile
duplicated contract definitions. This commit eliminates
this inefficiency.
---
 .../typed-racket/private/type-contract.rkt    | 13 ++-------
 .../static-contracts/instantiate.rkt          | 29 ++++++++++++++++---
 2 files changed, 28 insertions(+), 14 deletions(-)

diff --git a/typed-racket-lib/typed-racket/private/type-contract.rkt b/typed-racket-lib/typed-racket/private/type-contract.rkt
index ba2e50dd..ef9742bd 100644
--- a/typed-racket-lib/typed-racket/private/type-contract.rkt
+++ b/typed-racket-lib/typed-racket/private/type-contract.rkt
@@ -135,7 +135,7 @@
            [else
             (match-define (list defs ctc) result)
             (define maybe-inline-val
-              (should-inline-contract? ctc cache))
+              (should-inline-contract?/cache ctc cache))
             #`(begin #,@defs
                      #,@(if maybe-inline-val
                             null
@@ -153,18 +153,11 @@
 ;; Syntax (Dict Static-Contract (Cons Id Syntax)) -> (Option Syntax)
 ;; A helper for generate-contract-def/provide that helps inline contract
 ;; expressions when needed to cooperate with the contract system's optimizations
-(define (should-inline-contract? ctc-stx cache)
+(define (should-inline-contract?/cache ctc-stx cache)
   (and (identifier? ctc-stx)
        (let ([match? (assoc ctc-stx (hash-values cache) free-identifier=?)])
          (and match?
-              (or
-               ;; no need to generate an extra def for things that are already identifiers
-               (identifier? match?)
-               ;; ->* are handled specially by the contract system
-               (let ([sexp (syntax-e (cdr match?))])
-                 (and (pair? sexp)
-                      (or (free-identifier=? (car sexp) #'->)
-                          (free-identifier=? (car sexp) #'->*)))))
+              (should-inline-contract? (cdr match?))
               (cdr match?)))))
 
 ;; The below requires are needed since they provide identifiers that
diff --git a/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt b/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt
index 9ac77dfa..8b7738f9 100644
--- a/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt
+++ b/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt
@@ -23,7 +23,8 @@
     [instantiate
       (parametric->/c (a) ((static-contract? (-> #:reason (or/c #f string?) a))
                            (contract-kind? #:cache hash?)
-                           . ->* . (or/c a (list/c (listof syntax?) syntax?))))]))
+                           . ->* . (or/c a (list/c (listof syntax?) syntax?))))]
+    [should-inline-contract? (-> syntax? boolean?)]))
 
 ;; Providing these so that tests can work directly with them.
 (module* internals #f
@@ -129,7 +130,9 @@
   (define bound-names (make-parameter null))
   ;; sc-queue : records the order in which to return syntax objects
   (define sc-queue null)
-  (define (recur sc)
+  ;; top-level? is #t only for the first call and not for recursive
+  ;; calls, which helps for inlining
+  (define (recur sc [top-level? #f])
     (cond [(and cache (hash-ref cache sc #f)) => car]
           [(arr/sc? sc) (make-contract sc)]
           [(or (parametric->/sc? sc) (sealing->/sc? sc))
@@ -144,7 +147,14 @@
            (make-contract sc)]
           [else
            (define ctc (make-contract sc))
-           (cond [(and (not (identifier? ctc)) cache)
+           (cond [(and ;; when a contract benefits from inlining
+                       ;; (e.g., ->) and this contract appears
+                       ;; directly in a define-module-boundary-contract
+                       ;; position (i.e, top-level? is #t) then
+                       ;; don't generate a new identifier for it
+                       (or (not (should-inline-contract? ctc))
+                           (not top-level?))
+                       cache)
                   (define fresh-id (generate-temporary))
                   (hash-set! cache sc (cons fresh-id ctc))
                   (set! sc-queue (cons sc sc-queue))
@@ -170,7 +180,7 @@
                (recur body)))]
       [(? sc? sc)
        (sc->contract sc recur)]))
-  (define ctc (recur sc))
+  (define ctc (recur sc #t))
   (define name-defs (compute-defs sc))
   ;; These are extra contract definitions for the name static contracts
   ;; that are used for this type. Since these are shared across multiple
@@ -196,6 +206,17 @@
                   #`(define #,id #,ctc)))
         ctc))
 
+;; Determine whether the given contract syntax should be inlined or not.
+(define (should-inline-contract? stx)
+  (or
+   ;; no need to generate an extra def for things that are already identifiers
+   (identifier? stx)
+   ;; ->* are handled specially by the contract system
+   (let ([sexp (syntax-e stx)])
+     (and (pair? sexp)
+          (or (free-identifier=? (car sexp) #'->)
+              (free-identifier=? (car sexp) #'->*))))))
+
 ;; determine if a given name is free in the sc
 (define (name-free-in? name sc)
   (let/ec escape