From 78767f809a3b9833f1b8cafc20719150f689b1aa Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Thu, 12 May 2011 14:47:38 -0400
Subject: [PATCH] Add layer predicates.

original commit: 26cc2cf6dc81323463e0d448de890bbb2621a3ae
---
 collects/typed-scheme/optimizer/float.rkt |  4 +++-
 collects/typed-scheme/optimizer/utils.rkt | 28 ++++++++++++++++++++---
 2 files changed, 28 insertions(+), 4 deletions(-)

diff --git a/collects/typed-scheme/optimizer/float.rkt b/collects/typed-scheme/optimizer/float.rkt
index 50323c93..e49375f5 100644
--- a/collects/typed-scheme/optimizer/float.rkt
+++ b/collects/typed-scheme/optimizer/float.rkt
@@ -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)
diff --git a/collects/typed-scheme/optimizer/utils.rkt b/collects/typed-scheme/optimizer/utils.rkt
index ea6c8eb7..a037dfbb 100644
--- a/collects/typed-scheme/optimizer/utils.rkt
+++ b/collects/typed-scheme/optimizer/utils.rkt
@@ -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])