Small change toward avoiding consing selectors unnecessarily.
authorTony Garnock-Jones <tonygarnockjones@gmail.com>
Tue, 17 Jul 2018 13:49:47 +0100
changeset 392 618244a1ee07
parent 391 1d4b8c5e18a4
child 393 a8aa9b77e495
Small change toward avoiding consing selectors unnecessarily.
experiments/little-smalltalk/jit-SmallWorld-2015.rkt
--- a/experiments/little-smalltalk/jit-SmallWorld-2015.rkt	Tue Jul 17 13:31:28 2018 +0100
+++ b/experiments/little-smalltalk/jit-SmallWorld-2015.rkt	Tue Jul 17 13:49:47 2018 +0100
@@ -456,19 +456,16 @@
   (log-vm/jit-info "Final proc: ~a" final-proc)
   final-proc)
 
-(define (install-native-proc! vm class selector native-proc)
-  (define name-bytes (bv-bytes selector))
+(define (install-native-proc! vm class name-bytes native-proc)
   (define class-cache (hash-ref! (VM-cache vm) class make-weak-hash))
   (hash-set! class-cache name-bytes native-proc)
   native-proc)
 
-(define (lookup-method/cache vm class selector)
-  (define name-bytes (bv-bytes selector))
+(define (lookup-method/cache vm class name-bytes)
   (define class-cache (hash-ref! (VM-cache vm) class make-weak-hash))
-  (hash-ref! class-cache name-bytes (lambda () (lookup-method vm class selector))))
+  (hash-ref! class-cache name-bytes (lambda () (lookup-method vm class name-bytes))))
 
-(define (lookup-method vm class selector)
-  (define name-bytes (bv-bytes selector))
+(define (lookup-method vm class name-bytes)
   (let search ((class class))
     (and (not (eq? class (VM-nil vm)))
          (or (search-class-method-dictionary class name-bytes)
@@ -483,11 +480,11 @@
   (when (or (not (eq? (unbox mic-class) class))
             (not method))
     (set-box! mic-class class)
-    (set! method (lookup-method/cache vm class selector))
+    (set! method (lookup-method/cache vm class (bv-bytes selector)))
     (when (and method (not (procedure? method)))
       (set! method (install-native-proc! vm
                                          class
-                                         selector
+                                         (bv-bytes selector)
                                          (compile-native-proc vm method))))
     (set-box! mic-method method))
   (or method
@@ -495,13 +492,13 @@
         (send-dnu vm ctx (obj (VM-Array vm) (list->vector args)) class selector))))
 
 (define (send-dnu vm ctx arguments class selector)
-  (define dnu-selector (mkbv (obj-class selector) #"doesNotUnderstand:"))
-  (match (lookup-method/cache vm class dnu-selector)
+  (define dnu-name-bytes #"doesNotUnderstand:")
+  (match (lookup-method/cache vm class dnu-name-bytes)
     [#f (error 'send-message* "Unhandled selector ~a at class ~a" selector class)]
     [dnu-method
      (log-vm-warning "DNU -- arguments ~a class ~a selector ~a" arguments class selector)
      (apply-method class
-                   dnu-selector
+                   (mkbv (obj-class selector) dnu-name-bytes)
                    dnu-method
                    vm
                    ctx
@@ -511,7 +508,7 @@
                                 (clone-array arguments))))]))
 
 (define (send-message* vm ctx arguments class selector)
-  (match (lookup-method/cache vm class selector)
+  (match (lookup-method/cache vm class (bv-bytes selector))
     [#f (send-dnu vm ctx arguments class selector)]
     [new-method (apply-method class
                               selector
@@ -524,7 +521,7 @@
   (define native-proc
     (if (procedure? method)
         method
-        (install-native-proc! vm class selector (compile-native-proc vm method))))
+        (install-native-proc! vm class (bv-bytes selector) (compile-native-proc vm method))))
   (apply native-proc
          vm
          (if (procedure? ctx)