diff --git a/collects/typed-scheme/private/optimize.ss b/collects/typed-scheme/private/optimize.ss new file mode 100644 index 00000000..ca7db62a --- /dev/null +++ b/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])) \ No newline at end of file diff --git a/collects/typed-scheme/types/type-table.ss b/collects/typed-scheme/types/type-table.ss new file mode 100644 index 00000000..0cae12dc --- /dev/null +++ b/collects/typed-scheme/types/type-table.ss @@ -0,0 +1,15 @@ +#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) (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)]) \ No newline at end of file