Fix a problem generating contracts for FlVector exports. Add test for problem.

svn: r18603

original commit: cf017110a982fb24451691200dc05830136e9833

collects/tests/typed-scheme/succeed/flvector.ss

@@ -19,6 +19,7 @@
 
 ;; Check the FlVector type is exported
 (define: v : FlVector (flvector 1. 2. 3.))
+(define-struct: Foo ([vec : FlVector]) #:transparent)
 
 (check equal? (flvector 1. 2. 3. 4.) (flvector 1. 2. 3. 4.))
 (check equal? (flvector? (flvector 1. 2. 3.)) #t)

collects/typed-scheme/private/optimize.ss

@@ -0,0 +1,51 @@
+#lang scheme/base
+
+(require syntax/parse (for-template scheme/base scheme/unsafe/ops)
+         "../utils/utils.ss" unstable/match scheme/match unstable/syntax
+         (rep type-rep)
+         (types abbrev type-table utils))
+(provide optimize)
+
+(define-syntax-class float-opt-expr
+  (pattern e:opt-expr
+           #:when (match (type-of #'e)
+                    [(tc-result1: (== -Flonum type-equal?)) #t] [_ #f])
+           #:with opt #'e.opt))
+
+(define-syntax-class float-binary-op
+  #:literals (+ - * / = <= < > >= min max)
+  (pattern (~and i:id (~or + - * / = <= < > >= min max))
+           #:with unsafe (format-id #'here "unsafe-fl~a" #'i)))
+
+(define-syntax-class float-unary-op
+  #:literals (abs sin cos tan asin acos atan log exp)
+  (pattern (~and i:id (~or abs sin cos tan asin acos atan log exp))
+           #:with unsafe (format-id #'here "unsafe-fl~a" #'i)))
+
+(define-syntax-class opt-expr
+  (pattern e:opt-expr*
+           #:with opt (syntax-recertify #'e.opt this-syntax (current-code-inspector) #f)))
+
+(define-syntax-class opt-expr*
+  #:literal-sets (kernel-literals)
+  #:local-conventions ([#rx"^e" opt-expr]
+                       [#rx"^f" float-opt-expr])
+  (pattern (let-values ([ids e-rhs] ...) e-body ...)
+           #:with opt #'(let-values ([ids e-rhs.opt] ...) e-body.opt ...))
+  (pattern (#%plain-app op:float-unary-op f)
+           #:with opt #'(op.unsafe f.opt))
+  (pattern (#%plain-app op:float-binary-op f fs ...)
+           #:with opt 
+           (for/fold ([o #'f.opt])
+             ([e (syntax->list #'(fs.opt ...))])
+             #`(op.unsafe #,o #,e)))
+  (pattern (#%plain-app e ...)
+           #:with opt #'(#%plain-app e.opt ...))
+  (pattern other:expr
+           #:with opt #'other))
+
+(define (optimize stx)
+  (syntax-parse stx #:literal-sets (kernel-literals)
+    [(define-values ~! ids e:opt-expr)
+     (syntax/loc stx (define-values ids e.opt))]
+    [_ (printf "nothing happened") stx]))

collects/typed-scheme/typecheck/tc-expr-unit.ss

@@ -5,7 +5,7 @@
 (require syntax/kerncase mzlib/trace
          scheme/match (prefix-in - scheme/contract)
          "signatures.ss" "tc-envops.ss" "tc-metafunctions.ss"
-         (types utils convenience union subtype remove-intersect)
+         (types utils convenience union subtype remove-intersect type-table)
          (private-in parse-type type-annotation)
          (rep type-rep)
          (only-in (infer infer) restrict)
@@ -231,6 +231,7 @@
              (lambda (ann)
                (let* ([r (tc-expr/check/internal form ann)]
                       [r* (check-below r expected)])
+                 (add-typeof-expr form expected)
                  ;; around again in case there is an instantiation
                  ;; remove the ascription so we don't loop infinitely
                  (loop (remove-ascription form) r* #t)))]
@@ -242,13 +243,16 @@
                 ;; do the instantiation on the old type
                 (let* ([ts* (do-inst form ts)]
                        [ts** (ret ts* fs os)])
+                  (add-typeof-expr form ts**)
                   ;; make sure the new type is ok
                   (check-below ts** expected))]
                ;; no annotations possible on dotted results
-               [ty ty])]
+               [ty (add-typeof-expr form ty) ty])]
             ;; nothing to see here
             [checked? expected]
-            [else (tc-expr/check/internal form expected)]))))
+            [else (let ([t (tc-expr/check/internal form expected)])
+                    (add-typeof-expr form t)
+                    t)]))))
 
 (define (tc-or e1 e2 or-part [expected #f])
   (match (single-value e1)
@@ -469,8 +473,10 @@
                     [else (internal-tc-expr form)])])
       (match ty
         [(tc-results: ts fs os)
-         (let ([ts* (do-inst form ts)])
-           (ret ts* fs os))]))))
+         (let* ([ts* (do-inst form ts)]
+                [r (ret ts* fs os)])
+           (add-typeof-expr form r)
+           r)]))))
 
 (define (tc/send rcvr method args [expected #f])
   (match (tc-expr rcvr)

collects/typed-scheme/typed-scheme.ss

@@ -6,7 +6,7 @@
          (for-syntax 
           (except-in syntax/parse id)
           scheme/base
-          (private type-contract)
+          (private type-contract optimize)
           (types utils convenience)
 	  (typecheck typechecker provide-handling)
 	  (env type-environments type-name-env type-alias-env)
@@ -77,7 +77,12 @@
                                        (type-check #'(body2 ...)))]
                          [check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))]
                          [(transformed-body ...) (remove-provides #'(body2 ...))])]
-           [with-syntax ([(transformed-body ...) (change-contract-fixups #'(transformed-body ...))])])
+           [with-syntax ([(transformed-body ...) (change-contract-fixups #'(transformed-body ...))])]
+           
+           [with-syntax ([(transformed-body ...) 
+                          (if (optimize?)
+                              (map optimize (syntax->list #'(transformed-body ...)))
+                              #'(transformed-body ...))])])
         (do-time "Typechecked")
         #;(printf "checked ~a~n" module-name)
         #;(printf "created ~a types~n" (count!))

collects/typed-scheme/types/abbrev.ss

@@ -11,7 +11,7 @@
          scheme/flonum
          (prefix-in c: scheme/contract)
          (for-syntax scheme/base syntax/parse)
-	 (for-template scheme/base scheme/contract scheme/promise scheme/tcp))
+	 (for-template scheme/base scheme/contract scheme/promise scheme/tcp scheme/flonum))
 
 (provide (all-defined-out)
          (rename-out [make-Listof -lst]))

collects/typed-scheme/types/type-table.ss

@@ -0,0 +1,17 @@
+#lang scheme/base
+
+(require unstable/debug "../utils/utils.ss" (rep type-rep) (only-in (types abbrev utils) tc-results?) scheme/contract)
+
+(define table (make-hasheq))
+
+(define (reset-type-table) (set! table (make-hasheq)))
+
+(define (add-typeof-expr e t) 
+  (when (optimize?)
+    (hash-set! table e t)))
+
+(define (type-of e) (hash-ref table e))
+
+(p/c [add-typeof-expr (syntax? tc-results? . -> . any/c)]
+     [type-of (syntax? . -> . tc-results?)]
+     [reset-type-table (-> any/c)])

collects/typed-scheme/utils/utils.ss

@@ -14,6 +14,8 @@ at least theoretically.
 (provide reverse-begin)
 
 (provide
+ ;; optimization
+ optimize?
  ;; timing
  start-timing do-time  
  ;; logging
@@ -23,6 +25,8 @@ at least theoretically.
  ;; provide macros
  rep utils typecheck infer env private)
 
+(define optimize? (make-parameter #f))
+
 ;; fancy require syntax
 (define-syntax (define-requirer stx)
   (syntax-parse stx