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

Inline ->* contracts in type->contract generation

Browse Source 
The contract generation process was aggressively optimizing
some contracts, leading to a pessimization when interacting
with the contract system's own optimizations.

This inlining addition undoes a small portion of the contract
generation in some cases to better cooperate with the contract
system's optimizations.

This commit alone doesn't solve the optimization problem.
But it does when combined with the next commit.
This commit is contained in:
Asumu Takikawa 2015-10-27 23:23:44 -04:00
parent 0d4b2fb3f7
commit 555571c268
1 changed files with 21 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -122,10 +122,15 @@
"type" #,(pretty-format-type type #:indent 8)))]
[else
(match-define (list defs ctc) result)
(define maybe-inline-val
(should-inline-contract? ctc cache))
#`(begin #,@defs
(define-values (ctc-id) #,ctc)
#,@(if maybe-inline-val
null
(list #`(define-values (ctc-id) #,ctc)))
(define-module-boundary-contract #,untyped-id
#,orig-id ctc-id
#,orig-id
#,(or maybe-inline-val #'ctc-id)
#:pos-source #,blame-id
#:srcloc (vector (quote #,(syntax-source orig-id))
#,(syntax-line orig-id)
@ -133,6 +138,20 @@
#,(syntax-position orig-id)
#,(syntax-span orig-id))))])]))
;; 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)
(and (identifier? ctc-stx)
(let ([match? (assoc ctc-stx (hash-values cache) free-identifier=?)])
(and 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) #'->*))))
(cdr match?)))))
;; The below requires are needed since they provide identifiers that
;; may appear in the residual program.