Add layer predicates.

original commit: 26cc2cf6dc81323463e0d448de890bbb2621a3ae
This commit is contained in:
Vincent St-Amour 2011-05-12 14:47:38 -04:00
parent 69b3ea5f28
commit 78767f809a
2 changed files with 28 additions and 4 deletions

View File

@ -92,7 +92,9 @@
(when (and (not safe-to-opt?)
(isoftype? this-syntax -Real))
(log-close-call "binary, args all float-arg-expr, return type not Float"
this-syntax))
this-syntax
(for/first ([x (in-list (syntax->list #'(f1 f2 fs ...)))])
(not (subtypeof? x -Flonum)))))
safe-to-opt?)
#:with opt
(begin (log-optimization "binary float" #'op)

View File

@ -4,13 +4,14 @@
racket/dict syntax/id-table racket/syntax unstable/syntax
"../utils/utils.rkt"
(for-template scheme/base)
(types type-table utils subtype)
(types type-table utils subtype numeric-tower)
(rep type-rep))
(provide *log-file* *log-to-log-file?* log-optimization *log-optimizations?*
log-close-call *log-close-calls?*
*show-optimized-code*
subtypeof? isoftype?
in-integer-layer? in-rational-layer? in-float-layer? in-real-layer?
mk-unsafe-tbl
n-ary->binary
unboxed-gensym reset-unboxed-gensym
@ -39,9 +40,16 @@
;; This is meant to help users understand what hurts the performance of
;; their programs.
(define *log-close-calls?* (in-command-line? "--log-close-calls"))
(define (log-close-call kind stx)
(define (log-close-call kind stx [irritant #f])
(when *log-close-calls?*
(do-logging kind stx)))
(do-logging (if irritant
(format "~a - caused by: ~a - ~a - ~a - ~a"
kind
(syntax-source-file-name irritant)
(syntax-line irritant) (syntax-column irritant)
(syntax->datum irritant))
kind)
stx)))
;; if set to #t, the optimizer will dump its result to stdout before compilation
(define *show-optimized-code* #f)
@ -55,6 +63,20 @@
(match (type-of s)
[(tc-result1: (== t type-equal?)) #t] [_ #f]))
;; layer predicates
;; useful in some cases where subtyping won't do
(define (in-integer-layer? t)
(subtypeof? t -Int))
(define (in-rational-layer? t)
(and (subtypeof? t -Rat)
(not (subtypeof? t -Int))))
(define (in-float-layer? t)
(subtypeof? t -Flonum))
(define (in-real-layer? t)
(and (subtypeof? t -Real)
(not (subtypeof? t -Rat))
(not (subtypeof? t -Flonum))))
;; generates a table matching safe to unsafe promitives
(define (mk-unsafe-tbl generic safe-pattern unsafe-pattern)
(for/fold ([h (make-immutable-free-id-table)]) ([g generic])