suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Improve contract inlining

Browse Source 
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.
This commit is contained in:
Asumu Takikawa 2016-06-13 14:55:08 -04:00
parent bc6e9e80cc
commit 78e0100663
2 changed files with 28 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
typed-racket-lib/typed-racket/private/type-contract.rkt
View File

@ -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

29
typed-racket-lib/typed-racket/static-contracts/instantiate.rkt
View File

@ -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