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

remove contract overhead from static-contract code

Browse Source
This commit is contained in:
Andrew Kent 2016-10-22 19:50:06 -04:00
parent 24c64e9de0
commit 40143109ec
19 changed files with 200 additions and 192 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
typed-racket-lib/typed-racket/static-contracts/combinators/any.rkt
View File

@ -4,16 +4,18 @@
;; Allows optimizations as many combinators can be simplified if their arguments are any/sc
;; Ex: (listof/sc any/sc) => list?/sc
(require "../structures.rkt" "../constraints.rkt"
(require "../../utils/utils.rkt"
"../structures.rkt"
"../constraints.rkt"
racket/match
racket/contract
(contract-req)
(for-template racket/base racket/contract/base)
(for-syntax racket/base syntax/parse))
(provide
(contract-out
[any/sc static-contract?])
any/sc:)
(provide/cond-contract
[any/sc static-contract?])
(provide any/sc:)
;;Printing

26
typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt
View File

@ -3,22 +3,24 @@
;; Static contract for case->.
;; Like case-> doesn't support keyword arguments.
(require "../structures.rkt" "../constraints.rkt"
(require "../../utils/utils.rkt"
"../structures.rkt"
"../constraints.rkt"
racket/list racket/match
racket/contract
(contract-req)
(for-template racket/base racket/contract/base)
(for-syntax racket/base syntax/parse))
(provide
(contract-out
[case->/sc ((listof arr-combinator?) . -> . static-contract?)]
[arr/sc (-> (listof static-contract?)
(or/c static-contract? #f)
(or/c (listof static-contract?) #f)
static-contract?)])
case->/sc:
arr/sc:
(rename-out [arr-combinator? arr/sc?]))
(provide/cond-contract
[case->/sc ((listof arr-combinator?) . -> . static-contract?)]
[arr/sc (-> (listof static-contract?)
(or/c static-contract? #f)
(or/c (listof static-contract?) #f)
static-contract?)])
(provide case->/sc:
arr/sc:
(rename-out [arr-combinator? arr/sc?]))
(define (case->/sc arrs)

12
typed-racket-lib/typed-racket/static-contracts/combinators/control.rkt
View File

@ -3,16 +3,16 @@
;; Static contracts for control contracts.
;; Currently only supports prompt tags.
(require "../structures.rkt" "../constraints.rkt"
(require "../../utils/utils.rkt"
"../structures.rkt" "../constraints.rkt"
racket/list racket/match
racket/contract
(contract-req)
(for-template racket/base racket/contract/base)
(for-syntax racket/base syntax/parse))
(provide
(contract-out
[prompt-tag/sc ((listof static-contract?) (or/c (listof static-contract?) #f) . -> . static-contract?)])
prompt-tag/sc:)
(provide prompt-tag/sc:)
(provide/cond-contract
[prompt-tag/sc ((listof static-contract?) (or/c (listof static-contract?) #f) . -> . static-contract?)])
(struct prompt-tag-combinator combinator ()
#:transparent

26
typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt
View File

@ -3,24 +3,24 @@
;; Static contract for ->.
;; Supports the whole range of possible options that -> does.
(require "../structures.rkt" "../constraints.rkt"
(require "../../utils/utils.rkt"
"../structures.rkt" "../constraints.rkt"
racket/list racket/match
racket/contract
(contract-req)
(for-template racket/base racket/contract/base "../../utils/simple-result-arrow.rkt")
(for-syntax racket/base syntax/parse))
(provide
(contract-out
[function/sc (-> boolean?
(listof static-contract?)
(listof static-contract?)
(listof (list/c keyword? static-contract?))
(listof (list/c keyword? static-contract?))
(or/c #f static-contract?)
(or/c #f (listof static-contract?))
static-contract?)])
->/sc:)
(provide ->/sc:)
(provide/cond-contract
[function/sc (-> boolean?
(listof static-contract?)
(listof static-contract?)
(listof (list/c keyword? static-contract?))
(listof (list/c keyword? static-contract?))
(or/c #f static-contract?)
(or/c #f (listof static-contract?))
static-contract?)])
(struct function-combinator combinator (indices mand-kws opt-kws typed-side?)
#:property prop:combinator-name "->/sc"

14
typed-racket-lib/typed-racket/static-contracts/combinators/lengths.rkt
View File

@ -5,18 +5,18 @@
;; Ex: (list/sc any/sc) => (list-length/sc 1)
(require
"../../utils/utils.rkt"
"../structures.rkt"
"../terminal.rkt"
"simple.rkt"
racket/contract
(contract-req)
(for-template racket/base))
(provide
(contract-out
[rename list-length/sc* list-length/sc (natural-number/c . -> . static-contract?)]
[vector-length/sc (natural-number/c . -> . static-contract?)]
[empty-list/sc static-contract?]
[empty-vector/sc static-contract?]))
(provide/cond-contract
[rename list-length/sc* list-length/sc (natural-number/c . -> . static-contract?)]
[vector-length/sc (natural-number/c . -> . static-contract?)]
[empty-list/sc static-contract?]
[empty-vector/sc static-contract?])
(define-terminal-sc list-length/sc (n) #:flat
#`(λ (l) (and (list? l) (= #,n (length l)))))

37
typed-racket-lib/typed-racket/static-contracts/combinators/name.rkt
View File

@ -9,33 +9,34 @@
;; duplication that would result if we used ordinary recursive
;; static contracts.
(require "../structures.rkt"
(require "../../utils/utils.rkt"
"../structures.rkt"
"../constraints.rkt"
"../../rep/type-rep.rkt" ; only for contract
racket/contract
racket/dict
(contract-req)
racket/match
racket/syntax
syntax/id-table
syntax/private/id-table
(for-syntax racket/base
syntax/parse))
(provide with-new-name-tables
name/sc:
lookup-name-defined
set-name-defined
(contract-out
[get-all-name-defs
(-> (listof (list/c (listof identifier?)
static-contract?
static-contract?
static-contract?)))]
[lookup-name-sc (-> Type? symbol? (or/c #f static-contract?))]
[register-name-sc (-> Type?
(-> static-contract?)
(-> static-contract?)
(-> static-contract?)
any)]))
set-name-defined)
(provide/cond-contract
[get-all-name-defs
(-> (listof (list/c (listof identifier?)
static-contract?
static-contract?
static-contract?)))]
[lookup-name-sc (-> Type? symbol? (or/c #f static-contract?))]
[register-name-sc (-> Type?
(-> static-contract?)
(-> static-contract?)
(-> static-contract?)
any)])
(define name-sc-table (make-parameter (make-hash)))
(define name-defs-table (make-parameter (make-hash)))
@ -60,7 +61,7 @@
(define (get-all-name-defs)
(define name-scs (name-sc-table))
(for/list ([(type defs) (in-dict (name-defs-table))])
(for/list ([(type defs) (in-hash (name-defs-table))])
(define scs (hash-ref name-scs type))
(define gen-names (map name-combinator-gen-name scs))
(cons gen-names defs)))

12
typed-racket-lib/typed-racket/static-contracts/combinators/none.rkt
View File

@ -4,16 +4,16 @@
;; Allows optimizations as many combinators can be simplified if their arguments are none/sc
;; Ex: (listof/sc none/sc) => null?/sc
(require "../structures.rkt" "../constraints.rkt"
(require "../../utils/utils.rkt"
"../structures.rkt" "../constraints.rkt"
racket/match
racket/contract
(contract-req)
(for-template racket/base racket/contract/base)
(for-syntax racket/base syntax/parse))
(provide
(contract-out
[none/sc static-contract?])
none/sc:)
(provide none/sc:)
(provide/cond-contract
[none/sc static-contract?])
;;Printing

20
typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt
View File

@ -3,24 +3,16 @@
;; Static contracts for class constructs.
;; Currently supports object/c and class/c.
(require "../structures.rkt" "../constraints.rkt"
(require "../../utils/utils.rkt"
"../structures.rkt" "../constraints.rkt"
racket/list racket/match
racket/contract
(contract-req)
racket/syntax
typed-racket/utils/opaque-object
(for-template racket/base racket/class
typed-racket/utils/opaque-object)
(for-syntax racket/base syntax/parse))
(provide
(contract-out
[struct member-spec ([modifier symbol?] [id symbol?] [sc static-contract?])]
[object/sc (boolean? (listof object-member-spec?) . -> . static-contract?)]
[class/sc (boolean? (listof member-spec?) (listof symbol?) . -> . static-contract?)]
[instanceof/sc (static-contract? . -> . static-contract?)]))
(struct member-spec (modifier id sc) #:transparent)
(define field-modifiers '(field init init-field inherit-field))
@ -171,3 +163,9 @@
(match v
[(instanceof-combinator (list class))
#`(instanceof/c #,(f class))]))
(provide/cond-contract
[struct member-spec ([modifier symbol?] [id symbol?] [sc static-contract?])]
[object/sc (boolean? (listof object-member-spec?) . -> . static-contract?)]
[class/sc (boolean? (listof member-spec?) (listof symbol?) . -> . static-contract?)]
[instanceof/sc (static-contract? . -> . static-contract?)])

17
typed-racket-lib/typed-racket/static-contracts/combinators/parametric.rkt
View File

@ -3,23 +3,17 @@
;; Static contract for parametric->/c and sealing->/sc.
(require
"../../utils/utils.rkt"
"../structures.rkt"
"../constraints.rkt"
"../terminal.rkt"
racket/match
racket/contract
(contract-req)
(for-template racket/base racket/contract/parametric
typed-racket/utils/sealing-contract)
(for-syntax racket/base syntax/parse))
(provide
(contract-out
[parametric->/sc ((listof identifier?) static-contract? . -> . static-contract?)]
[parametric-var/sc (identifier? . -> . static-contract?)]
[sealing->/sc ((listof identifier?)
(list/c (listof symbol?) (listof symbol?) (listof symbol?))
static-contract? . -> . static-contract?)]
[sealing-var/sc (identifier? . -> . static-contract?)])
parametric->/sc:
sealing->/sc:
(rename-out
@ -28,6 +22,13 @@
[sealing-var/sc sealing-var/sc:]
[sealing-combinator? sealing->/sc?]))
(provide/cond-contract
[parametric->/sc ((listof identifier?) static-contract? . -> . static-contract?)]
[parametric-var/sc (identifier? . -> . static-contract?)]
[sealing->/sc ((listof identifier?)
(list/c (listof symbol?) (listof symbol?) (listof symbol?))
static-contract? . -> . static-contract?)]
[sealing-var/sc (identifier? . -> . static-contract?)])
(struct parametric-combinator combinator (vars)
#:transparent

12
typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt
View File

@ -6,16 +6,16 @@
;; Ex: (flat/sc #'number?)
(require
"../../utils/utils.rkt"
"../structures.rkt"
"../constraints.rkt"
racket/match
racket/contract)
(contract-req))
(provide
(contract-out
[flat/sc ((syntax?) ((or/c #f any/c)) . ->* . static-contract?)]
[chaperone/sc ((syntax?) ((or/c #f any/c)) . ->* . static-contract?)]
[impersonator/sc ((syntax?) ((or/c #f any/c)) . ->* . static-contract?)]))
(provide/cond-contract
[flat/sc ((syntax?) ((or/c #f any/c)) . ->* . static-contract?)]
[chaperone/sc ((syntax?) ((or/c #f any/c)) . ->* . static-contract?)]
[impersonator/sc ((syntax?) ((or/c #f any/c)) . ->* . static-contract?)])
(define (simple-contract-write-proc v port mode)
(match-define (simple-contract syntax kind name) v)

15
typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt
View File

@ -2,23 +2,24 @@
;; Static contract for struct/c.
(require "../structures.rkt" "../constraints.rkt"
(require "../../utils/utils.rkt"
"../structures.rkt" "../constraints.rkt"
racket/match
racket/contract
(contract-req)
(for-template racket/base racket/contract/base "../../utils/struct-type-c.rkt")
(for-syntax racket/base syntax/parse))
(provide
(contract-out
[struct/sc (identifier? boolean? (listof static-contract?) . -> . static-contract?)]
;; #f as argument indicates StructTypeTop, which should fail on
;; all reflective operations.
[struct-type/sc (any/c . -> . static-contract?)])
struct/sc:
struct-type/sc:)
(provide/cond-contract
[struct/sc (identifier? boolean? (listof static-contract?) . -> . static-contract?)]
;; #f as argument indicates StructTypeTop, which should fail on
;; all reflective operations.
[struct-type/sc (any/c . -> . static-contract?)])
(struct struct-combinator combinator (name mut?)
#:transparent

9
typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt
View File

@ -3,7 +3,8 @@
;; Static contracts for structural contracts.
;; Ex: list/sc, vectorof/sc
(require "../structures.rkt"
(require "../../utils/utils.rkt"
"../structures.rkt"
"../constraints.rkt"
racket/match
(for-syntax racket/base racket/syntax syntax/stx syntax/parse)
@ -74,7 +75,8 @@
(f a kind)))
#:with ctc
#`(-> #,@(stx-map (lambda (_) #'static-contract?) #'(pos ...)) static-contract?)
#:with provides #'(provide (contract-out [name ctc]) matcher-name)]
#:with provides #'(begin (provide matcher-name)
(provide/cond-contract [name ctc]))]
[pattern (name:id . rest:argument-description)
#:with struct-name (generate-temporary #'name)
#:with matcher-name (format-id #'name "~a:" #'name)
@ -100,7 +102,8 @@
(f a 'rest.variance)))
#:with ctc
#'(->* () #:rest (listof static-contract?) static-contract?)
#:with provides #'(provide (contract-out [name ctc]) matcher-name)]))
#:with provides #'(begin (provide matcher-name)
(provide/cond-contract [name ctc]))]))
(define-syntax (combinator-struct stx)

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

@ -2,27 +2,14 @@
;; Static contracts for unit contracts
(require "../structures.rkt" "../constraints.rkt"
(require "../../utils/utils.rkt"
"../structures.rkt" "../constraints.rkt"
racket/list racket/match
racket/dict
racket/contract
(contract-req)
racket/syntax
(for-template racket/base racket/unit)
(for-syntax racket/base syntax/parse))
(provide
(contract-out
[struct signature-spec ([name identifier?]
[members (listof identifier?)]
[scs (listof static-contract?)])]
[unit/sc (-> (listof signature-spec?)
(listof signature-spec?)
(listof identifier?)
(listof static-contract?)
static-contract?)]))
(struct signature-spec (name members scs) #:transparent)
(struct unit-combinator combinator ()
@ -107,3 +94,13 @@
(define (unit/sc imports exports init-depends invoke)
(unit-combinator (unit-spec imports exports init-depends invoke)))
(provide/cond-contract
[struct signature-spec ([name identifier?]
[members (listof identifier?)]
[scs (listof static-contract?)])]
[unit/sc (-> (listof signature-spec?)
(listof signature-spec?)
(listof identifier?)
(listof static-contract?)
static-contract?)])

53
typed-racket-lib/typed-racket/static-contracts/constraints.rkt
View File

@ -36,14 +36,15 @@
;;
(require
"../utils/utils.rkt"
racket/match
racket/list
racket/format
racket/function
racket/contract
(contract-req)
racket/dict
racket/set
syntax/id-table
syntax/private/id-table
"kinds.rkt"
"equations.rkt")
@ -53,36 +54,27 @@
merge-restricts*
merge-restricts
close-loop
(contract-out
[exn:fail:constraint-failure? predicate/c]
[exn:fail:constraint-failure-reason (exn:fail:constraint-failure? . -> . string?)]
[validate-constraints (contract-restrict? . -> . void?)]
[add-constraint (contract-restrict? contract-kind? . -> . contract-restrict?)])
contract-restrict-recursive-values
contract-restrict?
contract-restrict-value
kind-max-max)
(provide/cond-contract
[exn:fail:constraint-failure? predicate/c]
[exn:fail:constraint-failure-reason (exn:fail:constraint-failure? . -> . string?)]
[validate-constraints (contract-restrict? . -> . void?)]
[add-constraint (contract-restrict? contract-kind? . -> . contract-restrict?)])
(module structs racket/base
(require racket/contract
(require "../utils/utils.rkt"
(contract-req)
racket/match
racket/dict
racket/list
racket/set
syntax/id-table
syntax/private/id-table
"kinds.rkt")
(provide
(contract-out
;; constraint: value must be below max
[struct constraint ([value kind-max?] [max contract-kind?])]
;; kind-max: represents the maximum kind across all of the variables and the specified kind
[struct kind-max ([variables free-id-set?] [max contract-kind?])]
;; contract-restrict: represents a contract with value, recursive-values maps mentioned
;; recursive parts to kind-maxes, constraints are constraints that need to hold
[struct contract-restrict ([value kind-max?]
[recursive-values free-id-table?]
[constraints (set/c constraint?)])]))
(define free-id-set? free-id-table?)
(struct constraint (value max) #:transparent)
@ -141,7 +133,18 @@
(display ") " port)
(recur constraints port)
(display close port))]
#:transparent))
#:transparent)
(provide/cond-contract
;; constraint: value must be below max
[struct constraint ([value kind-max?] [max contract-kind?])]
;; kind-max: represents the maximum kind across all of the variables and the specified kind
[struct kind-max ([variables free-id-set?] [max contract-kind?])]
;; contract-restrict: represents a contract with value, recursive-values maps mentioned
;; recursive parts to kind-maxes, constraints are constraints that need to hold
[struct contract-restrict ([value kind-max?]
[recursive-values free-id-table?]
[constraints (set/c constraint?)])]))
(require 'structs)
(provide (struct-out kind-max))
@ -150,19 +153,19 @@
(define (free-id-set . elems)
(for/fold ([table (make-immutable-free-id-table)])
([e (in-list elems)])
(dict-set table e #t)))
(free-id-table-set table e #t)))
(define (free-id-set-union tables)
(for*/fold ([table (make-immutable-free-id-table)])
([new-table (in-list tables)]
[(k _) (in-dict new-table)])
(dict-set table k #t)))
(free-id-table-set table k #t)))
(define (free-id-table-union tables)
(for*/fold ([table (make-immutable-free-id-table)])
([new-table (in-list tables)]
[(k v) (in-dict new-table)])
(dict-set table k v)))
(free-id-table-set table k v)))
(define (simple-contract-restrict kind)
(contract-restrict (kind-max (free-id-set) kind) (make-immutable-free-id-table) (set)))

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

@ -3,6 +3,7 @@
;; Provides functionality to take a static contract and turn it into a regular contract.
(require
"../utils/utils.rkt"
racket/match
racket/dict
racket/contract
@ -18,13 +19,12 @@
"constraints.rkt"
"equations.rkt")
(provide
(contract-out
[instantiate
(parametric->/c (a) ((static-contract? (-> #:reason (or/c #f string?) a))
(contract-kind? #:cache hash?)
. ->* . (or/c a (list/c (listof syntax?) syntax?))))]
[should-inline-contract? (-> syntax? boolean?)]))
(provide/cond-contract
[instantiate
(parametric->/c (a) ((static-contract? (-> #:reason (or/c #f string?) a))
(contract-kind? #:cache hash?)
. ->* . (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

16
typed-racket-lib/typed-racket/static-contracts/kinds.rkt
View File

@ -4,15 +4,15 @@
;; 'flat, 'chaperone, and 'impersonator
;;
;; There is an ordering with 'flat < 'chaperone < 'impersonator.
(require "../utils/utils.rkt"
(contract-req)
racket/match)
(require racket/match racket/contract)
(provide
(contract-out
[contract-kind? predicate/c]
[contract-kind<= (contract-kind? contract-kind? . -> . boolean?)]
[kind->keyword (contract-kind? . -> . keyword?)]
[combine-kinds ((contract-kind?) #:rest (listof contract-kind?) . ->* . contract-kind?)]))
(provide/cond-contract
[contract-kind? predicate/c]
[contract-kind<= (contract-kind? contract-kind? . -> . boolean?)]
[kind->keyword (contract-kind? . -> . keyword?)]
[combine-kinds ((contract-kind?) #:rest (listof contract-kind?) . ->* . contract-kind?)])
(define (contract-kind? v)
(case v

12
typed-racket-lib/typed-racket/static-contracts/optimize.rkt
View File

@ -4,22 +4,22 @@
;; Also supports droping checks on either side.
(require
"../utils/utils.rkt"
(contract-req)
"combinators.rkt"
"structures.rkt"
racket/set
racket/syntax
racket/dict
syntax/id-table
syntax/private/id-table
racket/list
racket/contract
racket/match)
(provide
(contract-out
[optimize ((static-contract?) (#:trusted-positive boolean? #:trusted-negative boolean?)
. ->* . static-contract?)]))
(provide/cond-contract
[optimize ((static-contract?) (#:trusted-positive boolean? #:trusted-negative boolean?)
. ->* . static-contract?)])
;; Reduce a static contract to a smaller simpler one that protects in the same way
(define (reduce sc)

10
typed-racket-lib/typed-racket/static-contracts/parametric-check.rkt
View File

@ -4,18 +4,18 @@
;; contracts as direct descendents.
(require
"../utils/utils.rkt"
(contract-req)
racket/match
racket/contract
racket/dict
syntax/id-table
syntax/private/id-table
"structures.rkt"
"equations.rkt"
"combinators/parametric.rkt"
"combinators/structural.rkt")
(provide
(contract-out
[parametric-check (static-contract? . -> . boolean?)]))
(provide/cond-contract
[parametric-check (static-contract? . -> . boolean?)])
(define (parametric-check sc)

44
typed-racket-lib/typed-racket/static-contracts/structures.rkt
View File

@ -2,31 +2,14 @@
;; Internal structures for representing a static contract.
(require racket/match racket/list racket/generic
racket/contract
(require "../utils/utils.rkt"
(contract-req)
racket/match racket/list racket/generic
"kinds.rkt" "constraints.rkt")
(provide
(contract-out
(struct recursive-sc ([names (listof identifier?)]
[values (listof static-contract?)]
[body static-contract?]))
(struct recursive-sc-use ([name identifier?]))
(struct combinator ([args sequence?]))
(struct static-contract ())
[sc-map
(static-contract? (static-contract? variance/c . -> . static-contract?) . -> . static-contract?)]
[sc-traverse (static-contract? (static-contract? variance/c . -> . any/c) . -> . void?)]
[sc->contract (static-contract? (static-contract? . -> . syntax?) . -> . syntax?)]
[sc->constraints
(static-contract? (static-contract? . -> . contract-restrict?) . -> . contract-restrict?)]
[sc-terminal-kind (static-contract? . -> . (or/c #f contract-kind?))]
[sc? predicate/c])
(provide prop:combinator-name gen:sc)
prop:combinator-name
gen:sc)
(define variance/c (or/c 'covariant 'contravariant 'invariant))
(define-for-cond-contract variance/c (or/c 'covariant 'contravariant 'invariant))
(define (recursive-sc-write-proc v port mode)
(match-define (recursive-sc names vals body) v)
@ -162,3 +145,20 @@
#:transparent
#:property prop:combinator-name "combinator/sc"
#:methods gen:custom-write [(define write-proc combinator-write-proc)])
(provide/cond-contract
(struct recursive-sc ([names (listof identifier?)]
[values (listof static-contract?)]
[body static-contract?]))
(struct recursive-sc-use ([name identifier?]))
(struct combinator ([args sequence?]))
(struct static-contract ())
[sc-map
(static-contract? (static-contract? variance/c . -> . static-contract?) . -> . static-contract?)]
[sc-traverse (static-contract? (static-contract? variance/c . -> . any/c) . -> . void?)]
[sc->contract (static-contract? (static-contract? . -> . syntax?) . -> . syntax?)]
[sc->constraints
(static-contract? (static-contract? . -> . contract-restrict?) . -> . contract-restrict?)]
[sc-terminal-kind (static-contract? . -> . (or/c #f contract-kind?))]
[sc? predicate/c])