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

Refactoring.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-08-10 17:31:16 -04:00
parent cef410f5e2
commit 271f696c58
4 changed files with 84 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/typed-scheme/optimizer/apply.rkt
View File

@ -19,11 +19,13 @@
#:with opt #:with opt
(begin (reset-unboxed-gensym) (begin (reset-unboxed-gensym)
(with-syntax ([(f* lp v lst) (map unboxed-gensym '(f* loop v lst))] (with-syntax ([(f* lp v lst) (map unboxed-gensym '(f* loop v lst))]
[l ((optimize) #'l)] [l ((optimize) #'l)]
[f ((optimize) #'f)]) [f ((optimize) #'f)])
(log-optimization "apply-map" "apply-map deforestation." this-syntax) (log-optimization "apply-map" "apply-map deforestation."
#'(let ([f* f]) this-syntax)
#'(let ([f* f])
(let lp ([v op.identity] [lst l]) (let lp ([v op.identity] [lst l])
(if (null? lst) (if (null? lst)
v v
(lp (op v (f* (unsafe-car lst))) (unsafe-cdr lst))))))))) (lp (op v (f* (unsafe-car lst)))
(unsafe-cdr lst)))))))))

6
collects/typed-scheme/optimizer/number.rkt
View File

@ -10,8 +10,10 @@
(define-syntax-class number-opt-expr (define-syntax-class number-opt-expr
#:commit #:commit
;; these cases are all identity ;; these cases are all identity
(pattern (#%plain-app (~and op (~or (~literal +) (~literal *) (~literal min) (~literal max))) (pattern (#%plain-app (~and op (~or (~literal +) (~literal *)
(~literal min) (~literal max)))
f:expr) f:expr)
#:with opt #:with opt
(begin (log-optimization "unary number" "Identity elimination." this-syntax) (begin (log-optimization "unary number" "Identity elimination."
this-syntax)
((optimize) #'f)))) ((optimize) #'f))))

25
collects/typed-scheme/optimizer/unboxed-let.rkt
View File

@ -98,19 +98,18 @@
(doms doms)) (doms doms))
(cond [(null? params) (cond [(null? params)
;; done. can we unbox anything? ;; done. can we unbox anything?
(and (> (length unboxed) 0) (when (> (length unboxed) 0)
;; if so, add to the table of functions with ;; if so, add to the table of functions with
;; unboxed params, so we can modify its call ;; unboxed params, so we can modify its call
;; sites, its body and its header ;; sites, its body and its header)
(begin (log-optimization (log-optimization
"unboxed function -> table" "unboxed function -> table"
arity-raising-opt-msg arity-raising-opt-msg
fun-name) fun-name)
#t) (dict-set! unboxed-funs-table fun-name
(dict-set! unboxed-funs-table fun-name (list (reverse unboxed)
(list (reverse unboxed) (reverse boxed))))]
(reverse boxed))))] [(and (equal? (car doms) -FloatComplex)
[(and (equal? (car doms) -FloatComplex)
(could-be-unboxed-in? (could-be-unboxed-in?
(car params) #'(begin body ...))) (car params) #'(begin body ...)))
;; we can unbox ;; we can unbox

92
collects/typed-scheme/utils/tc-utils.rkt
View File

@ -9,12 +9,14 @@ don't depend on any other portion of the system
(require "syntax-traversal.rkt" racket/dict (require "syntax-traversal.rkt" racket/dict
syntax/parse (for-syntax scheme/base syntax/parse) racket/match) syntax/parse (for-syntax scheme/base syntax/parse) racket/match)
;; a parameter representing the original location of the syntax being currently checked ;; a parameter representing the original location of the syntax being
;; currently checked
(define current-orig-stx (make-parameter #'here)) (define current-orig-stx (make-parameter #'here))
(define orig-module-stx (make-parameter #f)) (define orig-module-stx (make-parameter #f))
(define expanded-module-stx (make-parameter #f)) (define expanded-module-stx (make-parameter #f))
;; a parameter holding the mutated variables for the form currently being checked ;; a parameter holding the mutated variables for the form currently being
;; checked
(define mutated-vars (make-parameter #hash())) (define mutated-vars (make-parameter #hash()))
(define (is-var-mutated? id) (dict-ref (mutated-vars) id #f)) (define (is-var-mutated? id) (dict-ref (mutated-vars) id #f))
@ -24,16 +26,18 @@ don't depend on any other portion of the system
(cond [(null? l) null] (cond [(null? l) null]
[(null? (cdr l)) l] [(null? (cdr l)) l]
[else (cons (car l) (cons v (intersperse v (cdr l))))])) [else (cons (car l) (cons v (intersperse v (cdr l))))]))
(apply string-append (intersperse between (map (lambda (s) (format "~a" s)) l)))) (apply string-append
(intersperse between (map (lambda (s) (format "~a" s)) l))))
;; helper function, not currently used ;; helper function, not currently used
(define (find-origin stx) (define (find-origin stx)
(cond [(syntax-property stx 'origin) => (lambda (orig) (cond [(syntax-property stx 'origin)
(let ([r (reverse orig)]) => (lambda (orig)
(let loop ([r (reverse orig)]) (let ([r (reverse orig)])
(if (null? r) #f (let loop ([r (reverse orig)])
(if (syntax-source (car r)) (car r) (if (null? r) #f
(loop (cdr r)))))))] (if (syntax-source (car r)) (car r)
(loop (cdr r)))))))]
[else #f])) [else #f]))
;; do we print the fully-expanded syntax in error messages? ;; do we print the fully-expanded syntax in error messages?
@ -49,10 +53,15 @@ don't depend on any other portion of the system
[stx (locate-stx e)]) [stx (locate-stx e)])
(when (and (warn-unreachable?) (when (and (warn-unreachable?)
(log-level? l 'warning) (log-level? l 'warning)
(and (syntax-transforming?) (syntax-original? (syntax-local-introduce e))) (and (syntax-transforming?)
#;(and (orig-module-stx) (eq? (debugf syntax-source-module e) (debugf syntax-source-module (orig-module-stx)))) (syntax-original? (syntax-local-introduce e)))
#;(syntax-source-module stx)) #;(and (orig-module-stx)
(log-message l 'warning (format "Typed Racket has detected unreachable code: ~.s" (syntax->datum (locate-stx e))) (eq? (debugf syntax-source-module e)
(debugf syntax-source-module (orig-module-stx))))
#;(syntax-source-module stx))
(log-message l 'warning
(format "Typed Racket has detected unreachable code: ~.s"
(syntax->datum (locate-stx e)))
e)))) e))))
(define (locate-stx stx) (define (locate-stx stx)
@ -90,20 +99,27 @@ don't depend on any other portion of the system
[l [l
(let ([stxs (let ([stxs
(for/list ([e l]) (for/list ([e l])
(sync (thread (lambda () (raise-typecheck-error (err-msg e) (err-stx e))))) (sync (thread
(lambda ()
(raise-typecheck-error (err-msg e) (err-stx e)))))
(err-stx e))]) (err-stx e))])
(reset!) (reset!)
(unless (null? stxs) (unless (null? stxs)
(raise-typecheck-error (format "Summary: ~a errors encountered" (length stxs)) (apply append stxs))))])) (raise-typecheck-error (format "Summary: ~a errors encountered"
(length stxs))
(apply append stxs))))]))
(define delay-errors? (make-parameter #f)) (define delay-errors? (make-parameter #f))
(define (tc-error/delayed msg #:stx [stx* (current-orig-stx)] . rest) (define (tc-error/delayed msg #:stx [stx* (current-orig-stx)] . rest)
(let ([stx (locate-stx stx*)]) (let ([stx (locate-stx stx*)])
(unless (syntax? stx) (unless (syntax? stx)
(int-err "erroneous syntax was not a syntax object: ~a ~a" stx (syntax->datum stx*))) (int-err "erroneous syntax was not a syntax object: ~a ~a"
stx (syntax->datum stx*)))
(if (delay-errors?) (if (delay-errors?)
(set! delayed-errors (cons (make-err (apply format msg rest) (list stx)) delayed-errors)) (set! delayed-errors (cons (make-err (apply format msg rest)
(list stx))
delayed-errors))
(raise-typecheck-error (apply format msg rest) (list stx))))) (raise-typecheck-error (apply format msg rest) (list stx)))))
;; produce a type error, using the current syntax ;; produce a type error, using the current syntax
@ -111,13 +127,18 @@ don't depend on any other portion of the system
(let* ([ostx (current-orig-stx)] (let* ([ostx (current-orig-stx)]
[ostxs (if (list? ostx) ostx (list ostx))] [ostxs (if (list? ostx) ostx (list ostx))]
[stxs (map locate-stx ostxs)]) [stxs (map locate-stx ostxs)])
;; If this isn't original syntax, then we can get some pretty bogus error messages. Note ;; If this isn't original syntax, then we can get some pretty bogus error
;; that this is from a macro expansion, so that introduced vars and such don't confuse the user. ;; messages. Note that this is from a macro expansion, so that introduced
;; vars and such don't confuse the user.
(cond (cond
[(or (not (orig-module-stx)) [(or (not (orig-module-stx))
(for/and ([s ostxs]) (eq? (syntax-source s) (syntax-source (orig-module-stx))))) (for/and ([s ostxs])
(raise-typecheck-error (apply format msg rest) stxs)] (eq? (syntax-source s) (syntax-source (orig-module-stx)))))
[else (raise-typecheck-error (apply format (string-append "Error in macro expansion -- " msg) rest) stxs)]))) (raise-typecheck-error (apply format msg rest) stxs)]
[else (raise-typecheck-error
(apply format (string-append "Error in macro expansion -- " msg)
rest)
stxs)])))
;; produce a type error, given a particular syntax ;; produce a type error, given a particular syntax
(define (tc-error/stx stx msg . rest) (define (tc-error/stx stx msg . rest)
@ -137,17 +158,22 @@ don't depend on any other portion of the system
;; raise an internal error - typechecker bug! ;; raise an internal error - typechecker bug!
(define (int-err msg . args) (define (int-err msg . args)
(raise (make-exn:fail:tc (string-append "Internal Typechecker Error: " (raise (make-exn:fail:tc
(apply format msg args) (string-append
(format "\nwhile typechecking:\n~a\noriginally:\n~a" "Internal Typechecker Error: "
(syntax->datum (current-orig-stx)) (apply format msg args)
(syntax->datum (locate-stx (current-orig-stx))))) (format "\nwhile typechecking:\n~a\noriginally:\n~a"
(current-continuation-marks)))) (syntax->datum (current-orig-stx))
(syntax->datum (locate-stx (current-orig-stx)))))
(current-continuation-marks))))
(define-syntax (nyi stx) (define-syntax (nyi stx)
(syntax-case stx () (syntax-case stx ()
[(_ str) [(_ str)
(quasisyntax/loc stx (int-err "~a: not yet implemented: ~a" str #,(syntax/loc stx (this-expression-file-name))))] (quasisyntax/loc stx
(int-err "~a: not yet implemented: ~a"
str
#,(syntax/loc stx (this-expression-file-name))))]
[(_) (syntax/loc stx (nyi ""))])) [(_) (syntax/loc stx (nyi ""))]))
@ -166,7 +192,11 @@ don't depend on any other portion of the system
#:transparent #:transparent
#:attributes (ty id) #:attributes (ty id)
(pattern [nm:identifier ~! ty] (pattern [nm:identifier ~! ty]
#:fail-unless (list? ((if (= 1 (syntax-local-phase-level)) identifier-template-binding identifier-template-binding) #'nm)) "not a bound identifier" #:fail-unless (list? ((if (= 1 (syntax-local-phase-level))
identifier-template-binding
identifier-template-binding)
#'nm))
"not a bound identifier"
#:with id #'(quote-syntax nm)) #:with id #'(quote-syntax nm))
(pattern [e:expr ty] (pattern [e:expr ty]
#:with id #'e)) #:with id #'e))