From b1aeeac4a9061c453234cc536401fa08334beb73 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 13 Dec 2009 04:39:46 +0000
Subject: [PATCH] bytecode-compiler changes to help enable flonum unboxing

svn: r17283

original commit: 5772fa0a9f595a8852638a5b1c0de7de2dbb0ef2
---
 collects/compiler/decompile.ss | 35 +++++++++++++++++++++++++++++-----
 1 file changed, 30 insertions(+), 5 deletions(-)

diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss
index 0ebc8b28a6..bb40aaf288 100644
--- a/collects/compiler/decompile.ss
+++ b/collects/compiler/decompile.ss
@@ -246,11 +246,13 @@
     [(struct application (rator rands))
      (let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand))
                           stack)])
-       (annotate-inline
-        `(,(decompile-expr rator globs stack closed)
-          ,@(map (lambda (rand)
-                   (decompile-expr rand globs stack closed))
-                 rands))))]
+       (annotate-unboxed
+        rands
+        (annotate-inline
+         `(,(decompile-expr rator globs stack closed)
+           ,@(map (lambda (rand)
+                    (decompile-expr rand globs stack closed))
+                  rands)))))]
     [(struct apply-values (proc args-expr))
      `(#%apply-values ,(decompile-expr proc globs stack closed) 
                       ,(decompile-expr args-expr globs stack closed))]
@@ -333,6 +335,29 @@
       (cons '#%in a)
       a))
 
+(define (annotate-unboxed args a)
+  (define (unboxable? e s)
+    (cond
+     [(localref? e) #t]
+     [(toplevel? e) #t]
+     [(eq? '#%flonum (car s)) #t]
+     [(not (expr? e)) #t]
+     [else #f]))
+  (if (and (symbol? (car a))
+           (case (length a)
+             [(2) (memq (car a) '(unsafe-flabs
+                                  unsafe-fx->fl))]
+             [(3) (memq (car a) '(unsafe-fl+ unsafe-fl- unsafe-fl* unsafe-fl/
+                                             unsafe-fl< unsafe-fl> 
+                                             unsafe-fl=
+                                             unsafe-fl<= unsafe-fl>=))]
+             
+             [(4) (memq (car a) '(unsafe-flvector-set!))]
+             [else #f])
+           (andmap unboxable? args (cdr a)))
+      (cons '#%flonum a)
+      a))
+
 ;; ----------------------------------------
 
 #;