AOT compilation of proxies, no interface change

2 files changed, 189 insertions, 177 deletions

diff --git a/src/clj/clojure/core-proxy.clj b/src/clj/clojure/core-proxy.clj
index 576fd4dd..ff65759d 100644
--- a/src/clj/clojure/core-proxy.clj
+++ b/src/clj/clojure/core-proxy.clj
@@ -16,185 +16,191 @@
  '(clojure.asm.commons Method GeneratorAdapter)
  '(clojure.lang IProxy Reflector DynamicClassLoader IPersistentMap PersistentHashMap RT))
 
-(def *proxy-classes* (ref {}))
-
 (defn method-sig [#^java.lang.reflect.Method meth]
   [(. meth (getName)) (seq (. meth (getParameterTypes))) (. meth getReturnType)])
 
-(defn get-proxy-class 
-  "Takes an optional single class followed by zero or more
-  interfaces. If not supplied class defaults to Object.  Creates an
-  returns an instance of a proxy class derived from the supplied
-  classes. The resulting value is cached and used for any subsequent
-  requests for the same class set. Returns a Class object."  
-  [& bases]
-    (let [bases (if (. (first bases) (isInterface))
-                  (cons Object bases)
-                  bases)
-          [super & interfaces] bases]
-      (or (get @*proxy-classes* bases)
-          (let [cv (new ClassWriter (. ClassWriter COMPUTE_MAXS))
-                cname (str "clojure/lang/" (gensym "Proxy__"))
-                ctype (. Type (getObjectType cname))
-                iname (fn [c] (.. Type (getType c) (getInternalName)))
-                fmap "__clojureFnMap"
-                totype (fn [c] (. Type (getType c)))
-                to-types (fn [cs] (if (pos? (count cs))
-                                    (into-array (map totype cs))
-                                    (make-array Type 0)))
-                super-type (totype super)
-                map-type (totype PersistentHashMap)
-                ifn-type (totype clojure.lang.IFn)
-                obj-type (totype Object)
-                sym-type (totype clojure.lang.Symbol)
-                rt-type  (totype clojure.lang.RT)
-                ex-type  (totype java.lang.UnsupportedOperationException)
-                gen-method
-                (fn [#^java.lang.reflect.Method meth else-gen]
-                  (let [pclasses (. meth (getParameterTypes))
-                        ptypes (to-types pclasses)
-                        rtype (totype (. meth (getReturnType)))
-                        m (new Method (. meth (getName)) rtype ptypes)
-                        gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)
-                        else-label (. gen (newLabel))
-                        end-label (. gen (newLabel))
-                        decl-type (. Type (getType (. meth (getDeclaringClass))))]
-                    (. gen (visitCode))
-                    (. gen (loadThis))
-                    (. gen (getField ctype fmap map-type))
+(defn proxy-name [super interfaces]
+  (apply str "clojure.proxy."
+         (.getName super)
+         (interleave (repeat "$")
+                     (sort (map #(.getSimpleName %) interfaces)))))
+
+(defn- generate-proxy [super interfaces]
+  (let [cv (new ClassWriter (. ClassWriter COMPUTE_MAXS))
+        cname (.replace (proxy-name super interfaces) \. \/) ;(str "clojure/lang/" (gensym "Proxy__"))
+        ctype (. Type (getObjectType cname))
+        iname (fn [c] (.. Type (getType c) (getInternalName)))
+        fmap "__clojureFnMap"
+        totype (fn [c] (. Type (getType c)))
+        to-types (fn [cs] (if (pos? (count cs))
+                            (into-array (map totype cs))
+                            (make-array Type 0)))
+        super-type (totype super)
+        map-type (totype PersistentHashMap)
+        ifn-type (totype clojure.lang.IFn)
+        obj-type (totype Object)
+        sym-type (totype clojure.lang.Symbol)
+        rt-type  (totype clojure.lang.RT)
+        ex-type  (totype java.lang.UnsupportedOperationException)
+        gen-method
+        (fn [#^java.lang.reflect.Method meth else-gen]
+            (let [pclasses (. meth (getParameterTypes))
+                  ptypes (to-types pclasses)
+                  rtype (totype (. meth (getReturnType)))
+                  m (new Method (. meth (getName)) rtype ptypes)
+                  gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)
+                  else-label (. gen (newLabel))
+                  end-label (. gen (newLabel))
+                  decl-type (. Type (getType (. meth (getDeclaringClass))))]
+              (. gen (visitCode))
+              (. gen (loadThis))
+              (. gen (getField ctype fmap map-type))
                                         ;get symbol corresponding to name
-                    (. gen (push (. meth (getName))))
-                    (. gen (invokeStatic sym-type (. Method (getMethod "clojure.lang.Symbol create(String)"))))
+              (. gen (push (. meth (getName))))
+              (. gen (invokeStatic sym-type (. Method (getMethod "clojure.lang.Symbol create(String)"))))
                                         ;lookup fn in map
-                    (. gen (invokeStatic rt-type (. Method (getMethod "Object get(Object, Object)"))))
-                    (. gen (dup))
-                    (. gen (ifNull else-label))
+              (. gen (invokeStatic rt-type (. Method (getMethod "Object get(Object, Object)"))))
+              (. gen (dup))
+              (. gen (ifNull else-label))
                                         ;if found
-                    (. gen (loadThis))
+              (. gen (loadThis))
                                         ;box args
-                    (dotimes [i (count ptypes)]
-                      (. gen (loadArg i))
-                      (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))
+              (dotimes [i (count ptypes)]
+                  (. gen (loadArg i))
+                (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i))))
                                         ;call fn
-                    (. gen (invokeInterface ifn-type (new Method "invoke" obj-type 
-                                                          (into-array (cons obj-type 
-                                                                            (replicate (count ptypes) obj-type))))))
+              (. gen (invokeInterface ifn-type (new Method "invoke" obj-type 
+                                                    (into-array (cons obj-type 
+                                                                      (replicate (count ptypes) obj-type))))))
                                         ;unbox return
-                    (. gen (unbox rtype))
-                    (when (= (. rtype (getSort)) (. Type VOID))
-                      (. gen (pop)))
-                    (. gen (goTo end-label))
-                    
+              (. gen (unbox rtype))
+              (when (= (. rtype (getSort)) (. Type VOID))
+                (. gen (pop)))
+              (. gen (goTo end-label))
+              
                                         ;else call supplied alternative generator
-                    (. gen (mark else-label))
-                    (. gen (pop))
-                    
-                    (else-gen gen m)
-                    
-                    (. gen (mark end-label))
-                    (. gen (returnValue))
-                    (. gen (endMethod))))]
-            
+              (. gen (mark else-label))
+              (. gen (pop))
+              
+              (else-gen gen m)
+              
+              (. gen (mark end-label))
+              (. gen (returnValue))
+              (. gen (endMethod))))]
+    
                                         ;start class definition
-            (. cv (visit (. Opcodes V1_5) (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_SUPER))
-                         cname nil (iname super) 
-                         (into-array (map iname (cons IProxy interfaces)))))
+    (. cv (visit (. Opcodes V1_5) (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_SUPER))
+                 cname nil (iname super) 
+                 (into-array (map iname (cons IProxy interfaces)))))
                                         ;add field for fn mappings
-            (. cv (visitField (+ (. Opcodes ACC_PRIVATE) (. Opcodes ACC_VOLATILE))
-                              fmap (. map-type (getDescriptor)) nil nil))          
+    (. cv (visitField (+ (. Opcodes ACC_PRIVATE) (. Opcodes ACC_VOLATILE))
+                      fmap (. map-type (getDescriptor)) nil nil))          
                                         ;add ctors matching/calling super's
-            (doseq [#^Constructor ctor (. super (getDeclaredConstructors))]
-              (when-not (. Modifier (isPrivate (. ctor (getModifiers))))
-                (let [ptypes (to-types (. ctor (getParameterTypes)))
-                      m (new Method "<init>" (. Type VOID_TYPE) ptypes)
-                      gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
-                  (. gen (visitCode))
+    (doseq [#^Constructor ctor (. super (getDeclaredConstructors))]
+        (when-not (. Modifier (isPrivate (. ctor (getModifiers))))
+          (let [ptypes (to-types (. ctor (getParameterTypes)))
+                m (new Method "<init>" (. Type VOID_TYPE) ptypes)
+                gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
+            (. gen (visitCode))
                                         ;call super ctor
-                  (. gen (loadThis))
-                  (. gen (dup))
-                  (. gen (loadArgs))
-                  (. gen (invokeConstructor super-type m))
+            (. gen (loadThis))
+            (. gen (dup))
+            (. gen (loadArgs))
+            (. gen (invokeConstructor super-type m))
                                         ;init fmap
-                  (. gen (getStatic map-type "EMPTY" map-type))
-                  (. gen (putField ctype fmap map-type))
-                  
-                  (. gen (returnValue))
-                  (. gen (endMethod)))))
-                                        ;add IProxy methods
-            (let [m (. Method (getMethod "void __updateClojureFnMappings(clojure.lang.IPersistentMap)"))
-                  gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
-              (. gen (visitCode))
-              (. gen (loadThis))
-              (. gen (dup))
-              (. gen (getField ctype fmap map-type))
-              (. gen (loadArgs))
-              (. gen (invokeInterface (totype clojure.lang.IPersistentCollection)
-                                      (. Method (getMethod "clojure.lang.IPersistentCollection cons(Object)"))))
-              (. gen (checkCast map-type))
-              (. gen (putField ctype fmap map-type))
-              
-              (. gen (returnValue))
-              (. gen (endMethod)))
-            (let [m (. Method (getMethod "clojure.lang.IPersistentMap __getClojureFnMappings()"))
-                  gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
-              (. gen (visitCode))
-              (. gen (loadThis))
-              (. gen (getField ctype fmap map-type))
-              (. gen (returnValue))
-              (. gen (endMethod)))
+            (. gen (getStatic map-type "EMPTY" map-type))
+            (. gen (putField ctype fmap map-type))
             
+            (. gen (returnValue))
+            (. gen (endMethod)))))
+                                        ;add IProxy methods
+    (let [m (. Method (getMethod "void __updateClojureFnMappings(clojure.lang.IPersistentMap)"))
+          gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
+      (. gen (visitCode))
+      (. gen (loadThis))
+      (. gen (dup))
+      (. gen (getField ctype fmap map-type))
+      (. gen (loadArgs))
+      (. gen (invokeInterface (totype clojure.lang.IPersistentCollection)
+                              (. Method (getMethod "clojure.lang.IPersistentCollection cons(Object)"))))
+      (. gen (checkCast map-type))
+      (. gen (putField ctype fmap map-type))
+      
+      (. gen (returnValue))
+      (. gen (endMethod)))
+    (let [m (. Method (getMethod "clojure.lang.IPersistentMap __getClojureFnMappings()"))
+          gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)]
+      (. gen (visitCode))
+      (. gen (loadThis))
+      (. gen (getField ctype fmap map-type))
+      (. gen (returnValue))
+      (. gen (endMethod)))
+    
                                         ;calc set of supers' non-private instance methods
-            (let [mm (loop [mm {} considered #{} c super]
-                       (if c
-                         (let [[mm considered]
-                               (loop [mm mm 
-                                      considered considered 
-                                      meths (concat 
-                                             (seq (. c (getDeclaredMethods)))
-                                             (seq (. c (getMethods))))]
-                                 (if meths 
-                                   (let [#^java.lang.reflect.Method meth (first meths)
-                                         mods (. meth (getModifiers))
-                                         mk (method-sig meth)]
-                                     (if (or (considered mk)
-                                             (. Modifier (isPrivate mods)) 
-                                             (. Modifier (isStatic mods))
-                                             (. Modifier (isFinal mods))
-                                             (= "finalize" (.getName meth)))
-                                       (recur mm (conj considered mk) (rest meths))
-                                       (recur (assoc mm mk meth) (conj considered mk) (rest meths))))
-                                   [mm considered]))]
-                           (recur mm considered (. c (getSuperclass))))
-                         mm))]
+    (let [mm (loop [mm {} considered #{} c super]
+               (if c
+                 (let [[mm considered]
+                       (loop [mm mm 
+                              considered considered 
+                              meths (concat 
+                                     (seq (. c (getDeclaredMethods)))
+                                     (seq (. c (getMethods))))]
+                         (if meths 
+                           (let [#^java.lang.reflect.Method meth (first meths)
+                                 mods (. meth (getModifiers))
+                                 mk (method-sig meth)]
+                             (if (or (considered mk)
+                                     (. Modifier (isPrivate mods)) 
+                                     (. Modifier (isStatic mods))
+                                     (. Modifier (isFinal mods))
+                                     (= "finalize" (.getName meth)))
+                               (recur mm (conj considered mk) (rest meths))
+                               (recur (assoc mm mk meth) (conj considered mk) (rest meths))))
+                           [mm considered]))]
+                   (recur mm considered (. c (getSuperclass))))
+                 mm))]
                                         ;add methods matching supers', if no mapping -> call super
-              (doseq [#^java.lang.reflect.Method meth (vals mm)]
-                     (gen-method meth 
-                                 (fn [gen m]
-                                   (. gen (loadThis))
+      (doseq [#^java.lang.reflect.Method meth (vals mm)]
+          (gen-method meth 
+                      (fn [gen m]
+                          (. gen (loadThis))
                                         ;push args
-                                   (. gen (loadArgs))
+                        (. gen (loadArgs))
                                         ;call super
-                                   (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL) 
-                                                           (. super-type (getInternalName))
-                                                           (. m (getName))
-                                                           (. m (getDescriptor)))))))
-              
+                        (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL) 
+                                                (. super-type (getInternalName))
+                                                (. m (getName))
+                                                (. m (getDescriptor)))))))
+      
                                         ;add methods matching interfaces', if no mapping -> throw
-              (doseq [#^Class iface interfaces]
-                (doseq [#^java.lang.reflect.Method meth (. iface (getMethods))]
-                   (when-not (contains? mm (method-sig meth))
-                     (gen-method meth 
-                                 (fn [gen m]
-                                   (. gen (throwException ex-type (. m (getName))))))))))
-
+      (doseq [#^Class iface interfaces]
+          (doseq [#^java.lang.reflect.Method meth (. iface (getMethods))]
+              (when-not (contains? mm (method-sig meth))
+                (gen-method meth 
+                            (fn [gen m]
+                                (. gen (throwException ex-type (. m (getName))))))))))
+    
                                         ;finish class def
-            (. cv (visitEnd))
-                                        ;generate, cache and return class object
-            (let [loader (. RT ROOT_CLASSLOADER)
-                  c (. loader (defineClass (. cname (replace "/" ".")) 
-                                (. cv (toByteArray))))]
-              (sync nil (commute *proxy-classes* assoc bases c))
-              c)))))
+    (. cv (visitEnd))
+    [cname (. cv toByteArray)]))
+
+(defn- get-super-and-interfaces [bases]
+  (if (. (first bases) (isInterface))
+    [Object bases]
+    [(first bases) (rest bases)]))
+
+(defn get-proxy-class 
+  "Takes an optional single class followed by zero or more
+  interfaces. If not supplied class defaults to Object.  Creates an
+  returns an instance of a proxy class derived from the supplied
+  classes. The resulting value is cached and used for any subsequent
+  requests for the same class set. Returns a Class object."  
+  [& bases]
+    (let [[super interfaces] (get-super-and-interfaces bases)
+          pname (proxy-name super interfaces)]
+      (or (RT/loadClassForName pname)
+          (let [[cname bytecode] (generate-proxy super interfaces)]
+            (. RT/ROOT_CLASSLOADER (defineClass pname bytecode))))))
 
 (defn construct-proxy
   "Takes a proxy class and any arguments for its superclass ctor and
@@ -244,21 +250,28 @@
   to protected members, nor to super, as these capabilities cannot be
   proxied."
   [class-and-interfaces args & fs]
-  `(let [pc# (get-proxy-class ~@class-and-interfaces)
-         p# (construct-proxy pc# ~@args)]   
-     (update-proxy p#
-       ~(loop [fmap {} fs fs]
-          (if fs
-            (let [[sym & meths] (first fs)
-                  meths (if (vector? (first meths))
-                          (list meths)
-                          meths)
-                  meths (map (fn [[params & body]]
-                               (cons (apply vector 'this params) body))
-                             meths)]
-              (recur (assoc fmap (list `quote (symbol (name sym))) (cons `fn meths)) (rest fs)))
-            fmap)))
-     p#))
+   (let [bases (map resolve class-and-interfaces)
+         [super interfaces] (get-super-and-interfaces bases)
+         compile-effect (when *compile-files*
+                          (let [[cname bytecode] (generate-proxy super interfaces)]
+                            (clojure.lang.Compiler/writeClassFile cname bytecode)))
+         pc-effect (apply get-proxy-class bases)
+         pname (proxy-name super interfaces)]
+     `(let [pc# (get-proxy-class ~@class-and-interfaces)
+            p# (new ~(symbol pname) ~@args)] ;(construct-proxy pc# ~@args)]   
+        (update-proxy p#
+         ~(loop [fmap {} fs fs]
+            (if fs
+              (let [[sym & meths] (first fs)
+                    meths (if (vector? (first meths))
+                            (list meths)
+                            meths)
+                    meths (map (fn [[params & body]]
+                                   (cons (apply vector 'this params) body))
+                               meths)]
+                (recur (assoc fmap (list `quote (symbol (name sym))) (cons `fn meths)) (rest fs)))
+              fmap)))
+        p#)))
 
 (defn proxy-call-with-super [call this meth]
  (let [m (proxy-mappings this)]
diff --git a/src/jvm/clojure/lang/RT.java b/src/jvm/clojure/lang/RT.java
index aca1bee2..ecb852ec 100644
--- a/src/jvm/clojure/lang/RT.java
+++ b/src/jvm/clojure/lang/RT.java
@@ -1476,15 +1476,14 @@ static public Class classForName(String name) throws ClassNotFoundException{
 	return Class.forName(name, false, baseLoader());
 }
 
-static public boolean loadClassForName(String name) throws Exception{
+static public Class loadClassForName(String name){
 	try{
-	Class.forName(name, true, baseLoader());
-	}
+    	return Class.forName(name, true, baseLoader());
+	    }
 	catch(ClassNotFoundException e)
 		{
-		return false;
+		return null;
 		}
-	return true;
 }
 
 static public float aget(float[] xs, int i){