From 56b372ca4d0d35e3bed9a5777dd01b974329d032 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 6 Sep 2013 14:22:04 -0400 Subject: [PATCH] Remember types that are defined, and use them in serialization. This extends a facility already available for base types, making that facility no longer strictly needed. Shrinks the zo size for the `math` package by almost 1MB. --- .../typed-racket/env/init-envs.rkt | 1 + .../typed-racket/typecheck/def-export.rkt | 7 +- .../typed-racket/typecheck/tc-toplevel.rkt | 31 ++--- .../typed-racket/types/abbrev.rkt | 36 +++--- .../typed-racket/types/base-abbrev.rkt | 12 +- .../typed-racket/types/numeric-tower.rkt | 108 +++++++++--------- 6 files changed, 103 insertions(+), 92 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt index ef3bdb7c31..3d2462bcb8 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/init-envs.rkt @@ -48,6 +48,7 @@ (define (gen-constructor sym) (string->symbol (string-append "make-" (substring (symbol->string sym) 7)))) (match v + [(? Rep? (app (lambda (v) (hash-ref predefined-type-table (Rep-seq v) #f)) (? values id))) id] [(Union: elems) `(make-Union (sort (list ,@(map sub elems)) < #:key Type-seq))] [(Base: n cnt pred marshaled _) marshaled] [(Name: stx) `(make-Name (quote-syntax ,stx))] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/def-export.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/def-export.rkt index 0db71d6b44..3dd3621c89 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/def-export.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/def-export.rkt @@ -9,6 +9,7 @@ (syntax-parse stx [(def-export export-id:identifier id:identifier cnt-id:identifier) #'(define-syntax export-id - (if (unbox typed-context?) - (renamer #'id #'cnt-id) - (renamer #'cnt-id)))])) + (let ([c #'cnt-id]) + (if (unbox typed-context?) + (renamer #'id c) + (renamer c))))])) 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 43d9661139..4c4d427299 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 @@ -380,21 +380,22 @@ #`(begin (begin-for-syntax (module* #%type-decl #f - (require typed-racket/types/numeric-tower typed-racket/env/type-name-env - typed-racket/env/global-env typed-racket/env/type-alias-env - typed-racket/types/type-table) - #,(env-init-code syntax-provide? provide-tbl def-tbl) - #,(talias-env-init-code) - #,(tname-env-init-code) - #,(tvariance-env-init-code) - #,(mvar-env-init-code mvar-env) - #,(make-struct-table-code) - #,@(for/list ([a (in-list aliases)]) - (match a - [(list from to) - #`(add-alias (quote-syntax #,from) (quote-syntax #,to))])))) - (begin-for-syntax (add-mod! (variable-reference->module-path-index - (#%variable-reference))))) + (#%plain-module-begin ;; avoid top-level printing and config + (require typed-racket/types/numeric-tower typed-racket/env/type-name-env + typed-racket/env/global-env typed-racket/env/type-alias-env + typed-racket/types/type-table typed-racket/types/abbrev) + #,(env-init-code syntax-provide? provide-tbl def-tbl) + #,(talias-env-init-code) + #,(tname-env-init-code) + #,(tvariance-env-init-code) + #,(mvar-env-init-code mvar-env) + #,(make-struct-table-code) + #,@(for/list ([a (in-list aliases)]) + (match a + [(list from to) + #`(add-alias (quote-syntax #,from) (quote-syntax #,to))]))))) + (begin-for-syntax (add-mod! (variable-reference->module-path-index + (#%variable-reference))))) #`(begin #,(if (null? (syntax-e #'(new-provs ...))) #'(begin) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt index c556b52cc2..43d86a7fff 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt @@ -83,7 +83,7 @@ (define -Listof (-poly (list-elem) (make-Listof list-elem))) -(define -Boolean (Un (-val #t) (-val #f))) +(define/decl -Boolean (Un (-val #t) (-val #f))) (define -Undefined (make-Base 'Undefined #'(lambda (x) (equal? (letrec ([y y]) y) x)) ; initial value of letrec bindings @@ -101,14 +101,14 @@ #'-PRegexp)) (define -Regexp (Un -PRegexp -Base-Regexp)) -(define -Byte-Base-Regexp (make-Base 'Byte-Regexp +(define -Byte-Base-Regexp (make-Base 'Byte-Base-Regexp #'(and/c byte-regexp? (not/c byte-pregexp?)) (conjoin byte-regexp? (negate byte-pregexp?)) - #'-Byte-Regexp)) + #'-Byte-Base-Regexp)) (define -Byte-PRegexp (make-Base 'Byte-PRegexp #'byte-pregexp? byte-pregexp? #'-Byte-PRegexp)) (define -Byte-Regexp (Un -Byte-Base-Regexp -Byte-PRegexp)) -(define -Pattern (Un -Bytes -Regexp -Byte-Regexp -String)) +(define/decl -Pattern (Un -Bytes -Regexp -Byte-Regexp -String)) @@ -119,7 +119,7 @@ (define -Keyword (make-Base 'Keyword #'keyword? keyword? #'-Keyword)) (define -Thread (make-Base 'Thread #'thread? thread? #'-Thread)) -(define -Module-Path (Un -Symbol -String +(define/decl -Module-Path (Un -Symbol -String (-lst* (-val 'quote) -Symbol) (-lst* (-val 'lib) -String) (-lst* (-val 'file) -String) @@ -135,7 +135,7 @@ #'(and/c compiled-expression? (not/c compiled-module-expression?)) (conjoin compiled-expression? (negate compiled-module-expression?)) #'-Compiled-Non-Module-Expression)) -(define -Compiled-Expression (Un -Compiled-Module-Expression -Compiled-Non-Module-Expression)) +(define/decl -Compiled-Expression (Un -Compiled-Module-Expression -Compiled-Non-Module-Expression)) (define -Cont-Mark-Set (make-Base 'Continuation-Mark-Set #'continuation-mark-set? continuation-mark-set? #'-Cont-Mark-Set)) (define -Path (make-Base 'Path #'path? path? #'-Path)) (define -OtherSystemPath (make-Base 'OtherSystemPath @@ -170,7 +170,7 @@ (make-Box sexp) t))) -(define -Sexp (-Sexpof (Un))) +(define/decl -Sexp (-Sexpof (Un))) (define Syntax-Sexp (-Sexpof Any-Syntax)) @@ -185,14 +185,14 @@ (define -VectorTop (make-VectorTop)) -(define -Port (Un -Output-Port -Input-Port)) +(define/decl -Port (Un -Output-Port -Input-Port)) -(define -SomeSystemPath (Un -Path -OtherSystemPath)) -(define -Pathlike (Un -String -Path)) -(define -SomeSystemPathlike (Un -String -SomeSystemPath)) -(define -Pathlike* (Un -String -Path (-val 'up) (-val 'same))) -(define -SomeSystemPathlike* (Un -String -SomeSystemPath(-val 'up) (-val 'same))) -(define -PathConventionType (Un (-val 'unix) (-val 'windows))) +(define/decl -SomeSystemPath (Un -Path -OtherSystemPath)) +(define/decl -Pathlike (Un -String -Path)) +(define/decl -SomeSystemPathlike (Un -String -SomeSystemPath)) +(define/decl -Pathlike* (Un -String -Path (-val 'up) (-val 'same))) +(define/decl -SomeSystemPathlike* (Un -String -SomeSystemPath(-val 'up) (-val 'same))) +(define/decl -PathConventionType (Un (-val 'unix) (-val 'windows))) @@ -244,7 +244,7 @@ (define -Logger (make-Base 'Logger #'logger? logger? #'-Logger)) (define -Log-Receiver (make-Base 'LogReceiver #'log-receiver? log-receiver? #'-Log-Receiver)) -(define -Log-Level (one-of/c 'fatal 'error 'warning 'info 'debug)) +(define/decl -Log-Level (one-of/c 'fatal 'error 'warning 'info 'debug)) (define -Place @@ -252,7 +252,7 @@ (define -Base-Place-Channel (make-Base 'Base-Place-Channel #'(and/c place-channel? (not/c place?)) (conjoin place-channel? (negate place?)) #'-Base-Place-Channel)) -(define -Place-Channel (Un -Place -Base-Place-Channel)) +(define/decl -Place-Channel (Un -Place -Base-Place-Channel)) (define -Will-Executor (make-Base 'Will-Executor #'will-executor? will-executor? #'-Will-Executor)) @@ -297,8 +297,8 @@ [(t) (make-pred-ty (list Univ) -Boolean t 0 null)])) -(define -true-filter (-FS -top -bot)) -(define -false-filter (-FS -bot -top)) +(define/decl -true-filter (-FS -top -bot)) +(define/decl -false-filter (-FS -bot -top)) (define (opt-fn args opt-args result) (apply cl->* (for/list ([i (in-range (add1 (length opt-args)))]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/base-abbrev.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/base-abbrev.rkt index b45a4d0eab..8763348692 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/base-abbrev.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/base-abbrev.rkt @@ -13,9 +13,17 @@ (rename-out [make-Listof -lst] [make-MListof -mlst])) +(define predefined-type-table (make-hasheq)) +(define-syntax-rule (declare-predefined-type! id) + (hash-set! predefined-type-table (Rep-seq id) #'id)) +(provide predefined-type-table) +(define-syntax-rule (define/decl id e) + (begin (define id e) + (declare-predefined-type! id))) + ;Top and error types -(define Univ (make-Univ)) -(define -Bottom (make-Union null)) +(define/decl Univ (make-Univ)) +(define/decl -Bottom (make-Union null)) (define Err (make-Error)) ;A Type that corresponds to the any contract for the diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/numeric-tower.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/numeric-tower.rkt index 7c0d6d347e..17e9c0a4aa 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/numeric-tower.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/numeric-tower.rkt @@ -50,16 +50,16 @@ (>= n 0))) ;; Singletons -(define -Zero (make-Value 0)) ; exact -(define -One (make-Value 1)) +(define/decl -Zero (make-Value 0)) ; exact +(define/decl -One (make-Value 1)) ;; Integers (define -Byte>1 (make-Base 'Byte-Larger-Than-One ; unsigned #'(and/c byte? (lambda (x) (> x 1))) (conjoin byte? (lambda (x) (> x 1))) #'-Byte>1)) -(define -PosByte (*Un -One -Byte>1)) -(define -Byte (*Un -Zero -PosByte)) +(define/decl -PosByte (*Un -One -Byte>1)) +(define/decl -Byte (*Un -Zero -PosByte)) (define -PosIndexNotByte (make-Base 'Positive-Index-Not-Byte ;; index? will be checked at runtime, can be platform-specific @@ -69,8 +69,8 @@ (positive? x) (not (byte? x)))) #'-PosIndexNotByte)) -(define -PosIndex (*Un -One -Byte>1 -PosIndexNotByte)) -(define -Index (*Un -Zero -PosIndex)) +(define/decl -PosIndex (*Un -One -Byte>1 -PosIndexNotByte)) +(define/decl -Index (*Un -Zero -PosIndex)) (define -PosFixnumNotIndex (make-Base 'Positive-Fixnum-Not-Index #'(and/c fixnum? positive? (not/c index?)) @@ -78,16 +78,16 @@ (positive? x) (not (portable-index? x)))) #'-PosFixnumNotIndex)) -(define -PosFixnum (*Un -PosFixnumNotIndex -PosIndex)) -(define -NonNegFixnum (*Un -PosFixnum -Zero)) +(define/decl -PosFixnum (*Un -PosFixnumNotIndex -PosIndex)) +(define/decl -NonNegFixnum (*Un -PosFixnum -Zero)) (define -NegFixnum (make-Base 'Negative-Fixnum #'(and/c fixnum? negative?) (lambda (x) (and (portable-fixnum? x) (negative? x))) #'-NegFixnum)) -(define -NonPosFixnum (*Un -NegFixnum -Zero)) -(define -Fixnum (*Un -NegFixnum -Zero -PosFixnum)) +(define/decl -NonPosFixnum (*Un -NegFixnum -Zero)) +(define/decl -Fixnum (*Un -NegFixnum -Zero -PosFixnum)) ;; This type, and others like it, should *not* be exported, or used for ;; anything but building unions. Especially, no literals should be given ;; these types. @@ -98,9 +98,9 @@ (positive? x) (not (portable-fixnum? x)))) #'-PosIntNotFixnum)) -(define -PosInt (*Un -PosIntNotFixnum -PosFixnum)) -(define -NonNegInt (*Un -PosInt -Zero)) -(define -Nat -NonNegInt) +(define/decl -PosInt (*Un -PosIntNotFixnum -PosFixnum)) +(define/decl -NonNegInt (*Un -PosInt -Zero)) +(define/decl -Nat -NonNegInt) (define -NegIntNotFixnum (make-Base 'Negative-Integer-Not-Fixnum #'(and/c exact-integer? negative? (not/c fixnum?)) @@ -108,9 +108,9 @@ (negative? x) (not (portable-fixnum? x)))) #'-NegIntNotFixnum)) -(define -NegInt (*Un -NegIntNotFixnum -NegFixnum)) -(define -NonPosInt (*Un -NegInt -Zero)) -(define -Int (*Un -NegInt -Zero -PosInt)) +(define/decl -NegInt (*Un -NegIntNotFixnum -NegFixnum)) +(define/decl -NonPosInt (*Un -NegInt -Zero)) +(define/decl -Int (*Un -NegInt -Zero -PosInt)) ;; Rationals (define -PosRatNotInt @@ -120,8 +120,8 @@ (positive? x) (not (exact-integer? x)))) #'-PosRatNotInt)) -(define -PosRat (*Un -PosRatNotInt -PosInt)) -(define -NonNegRat (*Un -PosRat -Zero)) +(define/decl -PosRat (*Un -PosRatNotInt -PosInt)) +(define/decl -NonNegRat (*Un -PosRat -Zero)) (define -NegRatNotInt (make-Base 'Negative-Rational-Not-Integer #'(and/c exact-rational? negative? (not/c integer?)) @@ -129,9 +129,9 @@ (negative? x) (not (exact-integer? x)))) #'-NegRatNotInt)) -(define -NegRat (*Un -NegRatNotInt -NegInt)) -(define -NonPosRat (*Un -NegRat -Zero)) -(define -Rat (*Un -NegRat -Zero -PosRat)) +(define/decl -NegRat (*Un -NegRatNotInt -NegInt)) +(define/decl -NonPosRat (*Un -NegRat -Zero)) +(define/decl -Rat (*Un -NegRat -Zero -PosRat)) ;; Floating-point numbers ;; NaN is included in all floating-point types @@ -147,22 +147,22 @@ #'(lambda (x) (eqv? x -0.0)) (lambda (x) (eqv? x -0.0)) #'-FlonumNegZero)) -(define -FlonumZero (*Un -FlonumPosZero -FlonumNegZero -FlonumNan)) +(define/decl -FlonumZero (*Un -FlonumPosZero -FlonumNegZero -FlonumNan)) (define -PosFlonumNoNan (make-Base 'Positive-Float-No-NaN #'(and/c flonum? positive?) (lambda (x) (and (flonum? x) (positive? x))) #'-PosFlonumNoNan)) -(define -PosFlonum (*Un -PosFlonumNoNan -FlonumNan)) -(define -NonNegFlonum (*Un -PosFlonum -FlonumZero)) +(define/decl -PosFlonum (*Un -PosFlonumNoNan -FlonumNan)) +(define/decl -NonNegFlonum (*Un -PosFlonum -FlonumZero)) (define -NegFlonumNoNan (make-Base 'Negative-Float-No-NaN #'(and/c flonum? negative?) (lambda (x) (and (flonum? x) (negative? x))) #'-NegFlonumNoNan)) -(define -NegFlonum (*Un -NegFlonumNoNan -FlonumNan)) -(define -NonPosFlonum (*Un -NegFlonum -FlonumZero)) -(define -Flonum (*Un -NegFlonumNoNan -FlonumNegZero -FlonumPosZero -PosFlonumNoNan -FlonumNan)) ; 64-bit floats +(define/decl -NegFlonum (*Un -NegFlonumNoNan -FlonumNan)) +(define/decl -NonPosFlonum (*Un -NegFlonum -FlonumZero)) +(define/decl -Flonum (*Un -NegFlonumNoNan -FlonumNegZero -FlonumPosZero -PosFlonumNoNan -FlonumNan)) ; 64-bit floats ;; inexact reals can be flonums (64-bit floats) or 32-bit floats (define -SingleFlonumNan (make-Base 'Single-Flonum-Nan #'(and/c single-flonum? (lambda (x) (eqv? x +nan.f))) @@ -179,11 +179,11 @@ #'(lambda (x) (eqv? x -0.0f0)) (lambda (x) (eqv? x -0.0f0)) #'-SingleFlonumNegZero)) -(define -SingleFlonumZero (*Un -SingleFlonumPosZero -SingleFlonumNegZero -SingleFlonumNan)) -(define -InexactRealNan (*Un -FlonumNan -SingleFlonumNan)) -(define -InexactRealPosZero (*Un -SingleFlonumPosZero -FlonumPosZero)) -(define -InexactRealNegZero (*Un -SingleFlonumNegZero -FlonumNegZero)) -(define -InexactRealZero (*Un -InexactRealPosZero +(define/decl -SingleFlonumZero (*Un -SingleFlonumPosZero -SingleFlonumNegZero -SingleFlonumNan)) +(define/decl -InexactRealNan (*Un -FlonumNan -SingleFlonumNan)) +(define/decl -InexactRealPosZero (*Un -SingleFlonumPosZero -FlonumPosZero)) +(define/decl -InexactRealNegZero (*Un -SingleFlonumNegZero -FlonumNegZero)) +(define/decl -InexactRealZero (*Un -InexactRealPosZero -InexactRealNegZero -InexactRealNan)) (define -PosSingleFlonumNoNan @@ -191,29 +191,29 @@ #'(and/c single-flonum? positive?) (lambda (x) (and (single-flonum? x) (positive? x))) #'-PosSingleFlonumNoNan)) -(define -PosSingleFlonum (*Un -PosSingleFlonumNoNan -SingleFlonumNan)) -(define -PosInexactReal (*Un -PosSingleFlonum -PosFlonum)) -(define -NonNegSingleFlonum (*Un -PosSingleFlonum -SingleFlonumZero)) -(define -NonNegInexactReal (*Un -PosInexactReal -InexactRealZero)) -(define -NegSingleFlonumNoNan +(define/decl -PosSingleFlonum (*Un -PosSingleFlonumNoNan -SingleFlonumNan)) +(define/decl -PosInexactReal (*Un -PosSingleFlonum -PosFlonum)) +(define/decl -NonNegSingleFlonum (*Un -PosSingleFlonum -SingleFlonumZero)) +(define/decl -NonNegInexactReal (*Un -PosInexactReal -InexactRealZero)) +(define/decl -NegSingleFlonumNoNan (make-Base 'Negative-Single-Flonum-No-Nan #'(and/c single-flonum? negative?) (lambda (x) (and (single-flonum? x) (negative? x))) #'-NegSingleFlonumNoNan)) -(define -NegSingleFlonum (*Un -NegSingleFlonumNoNan -SingleFlonumNan)) -(define -NegInexactReal (*Un -NegSingleFlonum -NegFlonum)) -(define -NonPosSingleFlonum (*Un -NegSingleFlonum -SingleFlonumZero)) -(define -NonPosInexactReal (*Un -NegInexactReal -InexactRealZero)) -(define -SingleFlonum (*Un -NegSingleFlonum -SingleFlonumNegZero -SingleFlonumPosZero -PosSingleFlonum -SingleFlonumNan)) -(define -InexactReal (*Un -SingleFlonum -Flonum)) +(define/decl -NegSingleFlonum (*Un -NegSingleFlonumNoNan -SingleFlonumNan)) +(define/decl -NegInexactReal (*Un -NegSingleFlonum -NegFlonum)) +(define/decl -NonPosSingleFlonum (*Un -NegSingleFlonum -SingleFlonumZero)) +(define/decl -NonPosInexactReal (*Un -NegInexactReal -InexactRealZero)) +(define/decl -SingleFlonum (*Un -NegSingleFlonum -SingleFlonumNegZero -SingleFlonumPosZero -PosSingleFlonum -SingleFlonumNan)) +(define/decl -InexactReal (*Un -SingleFlonum -Flonum)) ;; Reals -(define -RealZero (*Un -Zero -InexactRealZero)) -(define -PosReal (*Un -PosRat -PosInexactReal)) -(define -NonNegReal (*Un -NonNegRat -NonNegInexactReal)) -(define -NegReal (*Un -NegRat -NegInexactReal)) -(define -NonPosReal (*Un -NonPosRat -NonPosInexactReal)) -(define -Real (*Un -Rat -InexactReal)) +(define/decl -RealZero (*Un -Zero -InexactRealZero)) +(define/decl -PosReal (*Un -PosRat -PosInexactReal)) +(define/decl -NonNegReal (*Un -NonNegRat -NonNegInexactReal)) +(define/decl -NegReal (*Un -NegRat -NegInexactReal)) +(define/decl -NonPosReal (*Un -NonPosRat -NonPosInexactReal)) +(define/decl -Real (*Un -Rat -InexactReal)) ;; Complexes ;; We could go into _much_ more precision here. @@ -296,9 +296,9 @@ (single-flonum? (imag-part x)) (single-flonum? (real-part x)))) #'-SingleFlonumComplex)) -(define -ExactNumber (*Un -ExactImaginary -ExactComplex -Rat)) -(define -InexactImaginary (*Un -FloatImaginary -SingleFlonumImaginary)) -(define -Imaginary (*Un -ExactImaginary -InexactImaginary)) -(define -InexactComplex (*Un -FloatComplex -SingleFlonumComplex)) -(define -Complex (*Un -Real -Imaginary -ExactComplex -InexactComplex)) +(define/decl -ExactNumber (*Un -ExactImaginary -ExactComplex -Rat)) +(define/decl -InexactImaginary (*Un -FloatImaginary -SingleFlonumImaginary)) +(define/decl -Imaginary (*Un -ExactImaginary -InexactImaginary)) +(define/decl -InexactComplex (*Un -FloatComplex -SingleFlonumComplex)) +(define/decl -Complex (*Un -Real -Imaginary -ExactComplex -InexactComplex)) (define -Number -Complex)