diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/hidden-costs.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/hidden-costs.rkt index 93c6cbc8..1c516fe4 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/hidden-costs.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/hidden-costs.rkt @@ -4,9 +4,7 @@ (for-template racket/base) "../utils/utils.rkt" (optimizer utils logging) - (types abbrev)) - -(require (types type-table)) + (types abbrev type-table struct-table)) (provide hidden-cost-log-expr) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/struct.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/struct.rkt index b4a2934c..34fefaca 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/struct.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/struct.rkt @@ -4,7 +4,7 @@ (for-template racket/base racket/unsafe/ops) "../utils/utils.rkt" (utils tc-utils) - (types type-table) + (types type-table struct-table) (optimizer utils logging)) (provide struct-opt-expr) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt index 6592e6c4..c2e3b4fa 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt @@ -7,7 +7,7 @@ (prefix-in c: (contract-req)) (rep type-rep object-rep free-variance) (private parse-type syntax-properties) - (types abbrev utils resolve substitute type-table) + (types abbrev utils resolve substitute type-table struct-table) (env global-env type-name-env tvar-env) (utils tc-utils) (typecheck def-binding) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt index 4c4d4272..b7f4a96d 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt @@ -5,7 +5,7 @@ racket/list unstable/list racket/dict racket/match unstable/sequence (prefix-in c: (contract-req)) (rep type-rep free-variance) - (types utils abbrev type-table) + (types utils abbrev type-table struct-table) (private parse-type type-annotation type-contract syntax-properties) (env global-env init-envs type-name-env type-alias-env lexical-env env-req mvar-env scoped-tvar-env) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/struct-table.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/struct-table.rkt new file mode 100644 index 00000000..90982c92 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/struct-table.rkt @@ -0,0 +1,55 @@ +#lang racket/base + +(require racket/dict syntax/id-table racket/match + mzlib/pconvert racket/syntax + "../utils/utils.rkt" + (rep type-rep filter-rep object-rep) + (utils tc-utils) + (env init-envs) + (for-template + racket/base + (rep type-rep object-rep) + (types utils union) + (env init-envs) + (utils tc-utils))) + +(define struct-fn-table (make-free-id-table)) +(define struct-constructor-table (make-free-id-table)) + +(define (add-struct-constructor! id) (dict-set! struct-constructor-table id #t)) +(define (struct-constructor? id) (dict-ref struct-constructor-table id #f)) + +(define (add-struct-fn! id pe mut?) (dict-set! struct-fn-table id (list pe mut?))) + +(define-values (struct-accessor? struct-mutator?) + (let () + (define ((mk mut?) id) + (cond [(dict-ref struct-fn-table id #f) + => (match-lambda [(list pe m) (and (eq? m mut?) pe)] [_ #f])] + [else #f])) + (values (mk #f) (mk #t)))) + +(define (struct-fn-idx id) + (match (dict-ref struct-fn-table id #f) + [(list (StructPE: _ idx) _) idx] + [_ (int-err (format "no struct fn table entry for ~a" (syntax->datum id)))])) + +(define (make-struct-table-code) + (parameterize ([current-print-convert-hook converter] + [show-sharing #f]) + (define/with-syntax (adds ...) + (for/list ([(k v) (in-dict struct-fn-table)] + #:when (bound-in-this-module k)) + (match v + [(list pe mut?) + #`(add-struct-fn! (quote-syntax #,k) #,(print-convert pe) #,mut?)]))) + #'(begin adds ...))) + +(provide/cond-contract + [add-struct-fn! (identifier? StructPE? boolean? . -> . any/c)] + [add-struct-constructor! (identifier? . -> . any)] + [struct-constructor? (identifier? . -> . boolean?)] + [struct-accessor? (identifier? . -> . (or/c #f StructPE?))] + [struct-mutator? (identifier? . -> . (or/c #f StructPE?))] + [struct-fn-idx (identifier? . -> . exact-integer?)] + [make-struct-table-code (-> syntax?)]) \ No newline at end of file diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/type-table.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/type-table.rkt index 3bde7cb8..9d7cf9d4 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/type-table.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/type-table.rkt @@ -1,21 +1,11 @@ #lang racket/base ;; TODO figure out why these imports are needed even though they don't seem to be. -(require syntax/id-table racket/dict racket/match mzlib/pconvert - "../utils/utils.rkt" racket/syntax - "../utils/tc-utils.rkt" +(require racket/match + "../utils/utils.rkt" (contract-req) - (rep type-rep object-rep) (types utils union) - (utils tc-utils) - (env init-envs) - (for-template - racket/base - (rep type-rep object-rep) - (types utils union) - (utils tc-utils) - (env init-envs))) - + (utils tc-utils)) (define table (make-hasheq)) @@ -49,41 +39,6 @@ (syntax-line e) (syntax-column e)))))) - -(define struct-fn-table (make-free-id-table)) - -(define struct-constructor-table (make-free-id-table)) - -(define (add-struct-constructor! id) (dict-set! struct-constructor-table id #t)) -(define (struct-constructor? id) (dict-ref struct-constructor-table id #f)) - -(define (add-struct-fn! id pe mut?) (dict-set! struct-fn-table id (list pe mut?))) - -(define-values (struct-accessor? struct-mutator?) - (let () - (define ((mk mut?) id) - (cond [(dict-ref struct-fn-table id #f) - => (match-lambda [(list pe m) (and (eq? m mut?) pe)] [_ #f])] - [else #f])) - (values (mk #f) (mk #t)))) - -(define (struct-fn-idx id) - (match (dict-ref struct-fn-table id #f) - [(list (StructPE: _ idx) _) idx] - [_ (int-err (format "no struct fn table entry for ~a" (syntax->datum id)))])) - -(define (make-struct-table-code) - (parameterize ([current-print-convert-hook converter] - [show-sharing #f]) - (define/with-syntax (adds ...) - (for/list ([(k v) (in-dict struct-fn-table)] - #:when (bound-in-this-module k)) - (match v - [(list pe mut?) - #`(add-struct-fn! (quote-syntax #,k) #,(print-convert pe) #,mut?)]))) - #'(begin adds ...))) - - ;; keeps track of expressions that always evaluate to true or always evaluate ;; to false, so that the optimizer can eliminate dead code ;; 3 possible values: 'tautology 'contradiction 'neither @@ -117,13 +72,6 @@ [add-typeof-expr (syntax? tc-results/c . -> . any/c)] [type-of (syntax? . -> . tc-results/c)] [reset-type-table (-> any/c)] - [add-struct-fn! (identifier? StructPE? boolean? . -> . any/c)] - [add-struct-constructor! (identifier? . -> . any)] - [struct-constructor? (identifier? . -> . boolean?)] - [struct-accessor? (identifier? . -> . (or/c #f StructPE?))] - [struct-mutator? (identifier? . -> . (or/c #f StructPE?))] - [struct-fn-idx (identifier? . -> . exact-integer?)] - [make-struct-table-code (-> syntax?)] [add-tautology (syntax? . -> . any)] [add-contradiction (syntax? . -> . any)] [add-neither (syntax? . -> . any)]