remleduff committed 641574f

Make great strides towards supporting primitives

One could wish I'd committed this in smaller chunks...
1) Make emit a multimethod, ops can now implement either emit or
2) Fix loop types
3) Mostly implement set-boxed and expression-type in analysis, between
them, they contain the bulk of the logic for implementing primitives
4) Reflection was being misused, it returns symbols, and I was expecting
classes in many places
5) The match function in analysis now getting closer to correct. It will
need a full "find best matching method" implementation eventually

  • Participants
  • Parent commits 3a5f3fa

Comments (0)

Files changed (3)

File src/clojure/java/compiler.clj

            [org.objectweb.asm.util CheckClassAdapter TraceClassVisitor]
            [clojure.lang DynamicClassLoader RT Util]))
+;; TODO: It feels like expression-type shouldn't be called in this file, is it a performance problem?
+;;  if it is being called too much, it would be easy
+;; to make compute-type in analysis.clj add a :type key to everything. expression-type would then be able to short-circuit
+;; if there is already a :type
 (clojure.core/load "compiler/analysis")
 (def max-positional-arity 20)
 ; :locals - Local variable/Argument/Variable capture info, map from sym -> {:type :index}
 ; :protos - Fields for protocol support
 ; :loop-label - Label of the top of the current loop for recur
+; :loop-types - Types for the current loop top
 (def ^:dynamic ^:private *frame*) ; Contains per-class information
 (defn- new-frame [& m] (atom (apply hash-map :next-local-index 1 m))) ; 0 is "this"
 (defn- copy-frame [& {:as m}] (atom (merge @*frame* m)))
 (defmulti ^:private emit-boxed :op )
 (defmulti ^:private emit-unboxed :op )
-(defn ^:private emit [ast]
-  (if false #_(:unboxed ast)
-    (emit-unboxed ast)
-    (emit-boxed ast)))
+(defmulti ^:private emit :op)
+(defmethod emit :default [ast]
+  (if (:box ast)
+    (emit-boxed ast)
+    (emit-unboxed ast)))
 (defn load-class [name bytecode form]
   (let [binary-name (.replace name \/ \.)]
         (.accept cr v 0)))
     (.defineClass *loader* binary-name bytecode form)))
-(declare emit-class)
+(declare emit-class emit-box)
 (defn- emit-wrapper-fn [cv ast]
-  (binding [*gen* (GeneratorAdapter. Opcodes/ACC_PUBLIC (Method/getMethod "Object invoke()") nil nil cv)]
+  (binding [*gen* (GeneratorAdapter. Opcodes/ACC_PUBLIC (asm-method "invoke" "Object") nil nil cv)]
     (.visitCode *gen*)
     (emit ast)
     (.returnValue *gen*)
          (eval ret))
        (let [env {:ns (@namespaces *ns*) :context :statement :locals {}}
              ast (analyze env form)
-             ast (process-frames ast)
+             ast (process-frames (assoc ast :box true))
              internal-name (str "repl/Temp" (RT/nextID))
              cw (emit-class internal-name (assoc ast :super "clojure/lang/AFn") emit-wrapper-fn)]
          (let [bytecode (.toByteArray cw)
     ; Java clojure calls method.emitClearLocals here, but it does nothing?
     (.invokeInterface *gen* ifn-type (Method. "invoke" object-type (get arg-types (min (count args) (inc max-positional-arity)))))))
-(defmulti emit-convert (fn [t e] [t (class e)]))
-(defmethod emit-convert :default [t e]
-  (if (= t (class e)) (emit e) (println "Conversion not implemented")))
-(defn- emit-unchecked-cast [t p]
+(defn- emit-unchecked-cast [t]
   (let [m
           (= t Integer/TYPE) (Method/getMethod "int uncheckedIntCast(Object)")
           (= t Short/TYPE) (Method/getMethod "short uncheckedShortCast(Object)"))]
     (.invokeStatic *gen* rt-type m)))
-(defn- emit-checked-cast [t p]
+(defn- emit-checked-cast [t]
   (let [m
           (= t Integer/TYPE) (Method/getMethod "int intCast(Object)")
           (= t Short/TYPE) (Method/getMethod "short shortCast(Object)"))]
     (.invokeStatic *gen* rt-type m)))
-(defn- emit-cast-arg [t p]
-  (if (primitive? t)
-    (cond
-      (= t Boolean/TYPE)
-      (do
-        (.checkCast *gen* Type/BOOLEAN_TYPE)
-        (.invokeVirtual *gen* Type/BOOLEAN_TYPE (Method/getMethod "boolean booleanValue()")))
+(defn- emit-cast [t]
+  (cond
+    (= t Boolean/TYPE)
+    (do
+      (.checkCast *gen* (asm-type java.lang.Boolean))
+      (.invokeVirtual *gen* Type/BOOLEAN_TYPE (Method/getMethod "boolean booleanValue()")))
-      (= t Character/TYPE)
-      (do
-        (.checkCast *gen* Type/CHAR_TYPE)
-        (.invokeVirtual *gen* Type/CHAR_TYPE (Method/getMethod "char charValue()")))
+    (= t Character/TYPE)
+    (do
+      (.checkCast *gen* (asm-type java.lang.Character))
+      (.invokeVirtual *gen* Type/CHAR_TYPE (Method/getMethod "char charValue()")))
-      :else
-      (do
-        (.checkCast *gen* (asm-type java.lang.Number))
-        (if *unchecked-math*
-          (emit-unchecked-cast t p)
-          (emit-checked-cast t p))))))
+    (primitive? t)
+    (do
+      (.checkCast *gen* (asm-type java.lang.Number))
+      (if *unchecked-math*
+        (emit-unchecked-cast t)
+        (emit-checked-cast t)))
+    :else
+    (.checkCast *gen* (asm-type t))))
+(defmulti emit-convert (fn [actual-type desired-type] [actual-type desired-type]))
+(defmethod emit-convert [java.lang.Object Long/TYPE]
+  [actual-type desired-type]
+  (emit-cast desired-type))
+(defmethod emit-convert [java.lang.Object java.lang.Number]
+  [actual-type desired-type]
+  (emit-cast desired-type))
+(defmethod emit-convert :default
+  [actual-type desired-type]
+  (when-not (= actual-type desired-type) (println "Conversion not implemented" [actual-type desired-type])))
 (defn- emit-typed-arg [param-type arg]
+  (emit arg)
     (= param-type (expression-type arg))
-    (emit arg)
+    nil
     (convertible? (expression-type arg) param-type)
-    (emit-convert param-type arg)
+    (emit-convert (expression-type arg) param-type)
-    (do
-      (emit arg)
-      (emit-cast-arg param-type arg))))
+    (emit-cast param-type)))
 (defn- emit-typed-args [param-types args]
   (doall (map emit-typed-arg param-types args)))
-(defn- emit-box-return [type]
-  (when (primitive? type)
-    (.box *gen* (asm-type type))))
+(defn- emit-box [type]
+  (.box *gen* (asm-type type)))
 (defn- find-method [class filter error-msg]
   (let [members (-> class type-reflect :members)
             (throw (IllegalArgumentException. error-msg)))]
     (first methods)))
-(defn- emit-invoke-proto [{:keys [f args]}]
+(defn- emit-invoke-proto [{:keys [f args box]}]
   (let [{:keys [class statics protos]} @*frame*
         on-label (.newLabel *gen*)
         call-label (.newLabel *gen*)
           ; emit-clear-locals
           (println "Clear locals")
-        (let [r (:return-type meth)
-              m (apply asm-method (:name meth) r (:parameter-types meth))]
+        (let [{:keys [name return-type parameter-types]} meth
+              m (apply asm-method name return-type parameter-types)]
           (.invokeInterface *gen* (asm-type protocol-on) m)
-          (emit-box-return r))
+          (when box (emit-box return-type)))
         (.mark *gen* end-label)))))
 (defn- emit-invoke-fn [{:keys [f args env]}]
     (emit arg))
   (.invokeConstructor *gen* type (apply asm-method "<init>" "void" (map expression-type args))))
-(defmethod emit-boxed :new
+(defmethod emit :new
   [{:keys [ctor args env]}]
   (let [type (-> ctor :form asm-type)]
     (emit-instance type args)))
     (.getStatic (asm-type java.lang.Boolean) "FALSE" (asm-type java.lang.Boolean))
     (.visitJumpInsn Opcodes/IF_ACMPEQ false-label)))
-(defmethod emit-boxed :if
-  [{:keys [test then else env]}]
+(defmethod emit :if
+  [{:keys [test then else env box]}]
   (let [line (:line env)
         null-label (.newLabel *gen*)
         false-label (.newLabel *gen*)
 (defn- emit-constant [v box]
   (let [{:keys [class statics]} @*frame*
-        {:keys [name type]} (statics v)
-        type (asm-type type)]
-    (.getStatic *gen* class name type)
-    (when box (.box *gen* type))))
+        {:keys [name type]} (statics v)]
+    (.getStatic *gen* class name (asm-type type))
+    (when box (emit-box type))))
 (defmethod emit-boxed :constant [{:keys [form env]}]
   (if (nil? form)
           [sym {:index index :type type :label (.mark *gen*)}])))))
 (defn emit-method [cv {:as form :keys [name params statements ret env recurs type] :or {name "invoke" type java.lang.Object}}]
-  (binding [*gen* (GeneratorAdapter. Opcodes/ACC_PUBLIC (apply asm-method name type (map expression-type params)) nil nil cv)
+  (binding [*gen* (GeneratorAdapter. Opcodes/ACC_PUBLIC (apply asm-method name type (map tagged-type params)) nil nil cv)
             *frame* (copy-frame)]
     (.visitCode *gen*)
     (swap! *frame* assoc :locals (compute-locals form))
     (let [end-label (.newLabel *gen*)]
-      (swap! *frame* assoc :loop-label (.mark *gen*))
+      (swap! *frame* assoc :loop-label (.mark *gen*) :loop-types (map tagged-type params))
       (when statements
         (dorun (map emit-statement statements)))
       (emit ret)
     (emit-local name))
   (.invokeConstructor *gen* type (apply asm-method "<init>" "void" (map :type args))))
-(defmethod emit-boxed :fn [ast]
+(defmethod emit :fn [ast]
   (let [name (str (or (:name ast) (gensym)))
         cw (emit-class name (assoc ast :super "clojure/lang/AFn") emit-fn-methods)
         bytecode (.toByteArray cw)
         type (asm-type class)]
     (emit-closure type (closed-overs ast))))
-(defmethod emit-boxed :do
-  [{:keys [statements ret env]}]
+(defmethod emit :do
+  [{:keys [statements ret env box]}]
   (when statements
     (dorun (map emit-statement statements)))
   (emit ret))
           [name {:index i :type type :label (.mark *gen*)}]))
-(defmethod emit-boxed :let [{:keys [bindings statements ret env loop]}]
+(defmethod emit :let [{:keys [bindings statements ret env loop box]}]
   (binding [*frame* (copy-frame)]
     (let [bs (emit-bindings bindings)]
       (when loop
-        (swap! *frame* assoc :loop-label (.mark *gen*)))
+        (swap! *frame* assoc :loop-label (.mark *gen*) :loop-types (map #(-> % :name bs :type) bindings)))
       (when statements
         (dorun (map emit-statement statements)))
       (emit ret)
         (doseq [[name {:keys [type label index]}] bs]
           (.visitLocalVariable *gen* (str name) (-> type asm-type .getDescriptor) nil label end-label index))))))
-(defmethod emit-boxed :recur [{:as form :keys [env frame exprs]}]
-  (emit-typed-args (map expression-type exprs) exprs)
+(defmethod emit :recur [{:as form :keys [env frame exprs box]}]
+  (emit-typed-args (:loop-types @*frame*) exprs)
   (dorun (map
            (fn [name]
              (let [{:keys [type index]} (-> @*frame* :locals name)]
   (.goTo *gen* (:loop-label @*frame*)))
 (defn- emit-field
-  [env target field box-result]
+  [env target field box]
   (let [class (expression-type target)
         members (-> class type-reflect :members)
         field-info (select #(= (:name %) field) members)
         type (:type field-info)]
-  (if type
-    (do
-      (.getField *gen* (asm-type class) field (asm-type type))
-      (when box-result (emit-box-return type)))
-    (do
-      (when *warn-on-reflection*
-        (.format (RT/errPrintWriter)
-          "Reflection warning, %s:%d - reference to field %s can't be resolved.\n"
+    (if type
+      (do
+        (.getField *gen* (asm-type class) field (asm-type type))
+        (when box (emit-box type)))
+      (do
+        (when *warn-on-reflection*
+          (.format (RT/errPrintWriter)
+            "Reflection warning, %s:%d - reference to field %s can't be resolved.\n"
           *file* (make-array (-> target :env :line) field)))
-      (.push *gen* (name field))
-      (.invokeStatic *gen* (asm-type clojure.lang.Reflector)
-                           (Method/getMethod "Object invokeNoArgInstanceMember(Object,String)"))))))
+        (.push *gen* (name field))
+        (.invokeStatic *gen* (asm-type clojure.lang.Reflector)
+                             (Method/getMethod "Object invokeNoArgInstanceMember(Object,String)"))))))
-(defn- emit-method-call [target name args]
-  (let [class (expression-type target)
+(defn- emit-method-call [target name args box]
+  (let [class (:type target)
         meth (find-method class (match name args)
-               (str "No single method: " name " of class: " class " found with args: " args))]
-  (emit-typed-args (:parameter-types meth) (rest args))
-  (let [r (:return-type meth)
-        m (apply asm-method (:name meth) r (:parameter-types meth))]
+                                (apply str "No single method: " name " of class: " class " found with args: " (map expression-type args)))
+        {:keys [name return-type parameter-types]} meth
+        m (apply asm-method name return-type parameter-types)
+        return-type (maybe-class return-type)
+        parameter-types (map maybe-class parameter-types)]
+    (.checkCast *gen* (asm-type class))
+    (emit-typed-args parameter-types args)
     (.invokeVirtual *gen* (asm-type class) m)
-    (emit-box-return r))))
+    (when box (emit-box return-type))))
-(defmethod emit-boxed :dot
-  [{:keys [target field method args env]}]
+(defmethod emit :dot
+  [{:keys [target field method args env box]}]
   (emit target)
   (if field
-    (emit-field env target field true)
-    (emit-method-call target method args)))
+    (emit-field env target field box)
+    (emit-method-call target method args box)))
 (defn- emit-fns
   [cv {:as ast :keys [name type fns]}]
   (doseq [fn fns]
     (emit-fn-methods cv fn)))
-(defmethod emit-boxed :reify
+(defmethod emit :reify
   [{:as ast :keys [methods ancestors]}]
   (let [name (str (gensym "reify__"))
         c (-> ancestors first maybe-class)
         type (asm-type class)]
     (emit-closure type (closed-overs ast))))
-(defmethod emit-boxed :vector [args]
+(defmethod emit :vector [args]
   (emit-as-array (:children args))
   (.invokeStatic *gen* rt-type (Method/getMethod "clojure.lang.IPersistentVector vector(Object[])")))
-(defmethod emit-boxed :map [{:keys [keys vals]}]
+(defmethod emit :map [{:as form :keys [keys vals]}]
   (emit-as-array (interleave keys vals))
   (.invokeStatic *gen* rt-type (Method/getMethod "clojure.lang.IPersistentMap map(Object[])")))
-(defmethod emit-boxed :default [args] (notsup "Unknown operator: " (:op args) "\nForm: " args))
+(defmethod emit-boxed :default [args] (notsup "Unknown boxed operator: " (:op args) "\nForm: " args))
+(defmethod emit-unboxed :default [args] (notsup "Unknown unboxed operator: " (:op args) "\nForm: " args))

File src/clojure/java/compiler/analysis.clj

                        (var? v) v)]
         (.isDynamic var))))
+(defn protocol-node? [ast]
+  (when-let [name (-> ast :f :info :name)]
+    (when-let [var (resolve name)]
+      (-> var meta :protocol))))
 (defmulti expression-type
   "Returns the type of the ast node provided, or Object if unknown. Respects :tag metadata"
-  :op )
+  :op)
+(defn tagged-type [o]
+  (if-let [tag (-> o meta :tag)]
+    tag
+    java.lang.Object))
-(defmethod expression-type :default [{tag :tag}]
-  (if tag tag java.lang.Object))
+(defmethod expression-type :default [{type :type}]
+  (if type type java.lang.Object))
 (defmethod expression-type :constant [ast]
   (let [class (-> ast :form class)
-        unboxed (:unboxed ast)]
+        boxed (:box ast)]
     (condp #(isa? %2 %1) class
-             java.lang.Integer (if unboxed Long/TYPE Long)
-             java.lang.Long (if unboxed Long/TYPE Long)
-             java.lang.Float (if unboxed Double/TYPE Double)
-             java.lang.Double (if unboxed Double/TYPE Double)
+             java.lang.Integer (if boxed Long Long/TYPE)
+             java.lang.Long (if boxed Long Long/TYPE)
+             java.lang.Float (if boxed Double Double/TYPE)
+             java.lang.Double (if boxed Double Double/TYPE)
              java.lang.String java.lang.String
              java.lang.Class java.lang.Class
              clojure.lang.Keyword clojure.lang.Keyword
              nil nil
+(defmethod expression-type :local [{:keys [info]}]
+  (expression-type (:init info)))
+(defmethod expression-type :def [form]
+  clojure.lang.Var)
+(defmethod expression-type :var
+  [{:as form :keys [info]}]
+  (let [sym (:name info)
+        var (resolve (:form form))]
+    (if var
+      (class @var)
+      java.lang.Object)))
+(defmethod expression-type :do
+  [{:keys [ret]}]
+  (expression-type ret))
+(defmethod expression-type :let
+  [{:keys [ret]}]
+  (expression-type ret))
+(defmethod expression-type :if
+  [{:keys [then else]}]
+  (let [then-type (expression-type then)
+        else-type (expression-type else)]
+    (if (= then-type else-type)
+      then-type
+      (cond
+        (nil? then-type) else-type
+        (nil? else-type) then-type
+        :else java.lang.Object))))
+(defmethod expression-type :recur
+  [form]
+  nil)
 (defmulti convertible? (fn [t1 t2] [(maybe-class t1) (maybe-class t2)]))
+(defmethod convertible? [java.lang.Object java.lang.Number] [t1 ts] true)
+(defmethod convertible? [java.lang.Object Long/TYPE] [t1 ts] true)
 (defmethod convertible? :default [t1 t2]
   (if (= t1 t2) true (println "Conversion not implemented: " [t1 t2])))
   (fn match-method [method]
     (and (= name (:name method))
       (= (count args) (-> method :parameter-types count))
-      #_(every? true? (map #(do (println %) (convertible? %)) args (:parameter-types method))))))
+      (every? true? (map #(do #_(println (expression-type %1) %2) (convertible? (expression-type %1) (maybe-class %2))) args (:parameter-types method))))))
 ;; ---
                    form (walk-node this form)]
                (post form)))))
-(defmulti set-unbox :op)
+(defmulti set-box :op)
+(defn boxed? [form]
+  (:box (set-box form)))
+(defmethod set-box :map
+  [form]
+  (walk-node #(assoc % :box true) (assoc form :box true)))
+(defmethod set-box :vector
+  [form]
+  (walk-node #(assoc % :box true) (assoc form :box true)))
+(defmethod set-box :def
+  [form]
+  (assoc-in form [:init :box] true))
+(defmethod set-box :invoke
+  [form]
+  (if-not (protocol-node? form)
+    (walk-node #(assoc % :box true) (assoc form :box true))
+    form))
-(defmethod set-unbox :default
-  [{:as form :keys [unbox op]}]
-  (walk-node #(assoc % :unbox (or unbox (= op :let))) form))
+(defmethod set-box :do
+  [form]
+  (if (:box form)
+    (assoc-in form [:ret :box] true)
+    form))
+(defmethod set-box :let
+  [form]
+  ;; TODO: Smarter boxing for loops
+  (let [form (if (:loop form) (assoc form :box true) form)]
+    (if (:box form)
+      (assoc-in form [:ret :box] true)
+      form)))
+(defmethod set-box :if
+  [form]
+  ;; Always box the test, otherwise (if nil) can't work
+  (let [form (assoc-in form [:test :box] true)]
+    (if (or (:box form) (boxed? (:then form)) (boxed? (:else form)))
+      (-> form
+        (assoc-in [:then :box] true)
+        (assoc-in [:else :box] true))
+      form)))
+(defmethod set-box :fn
+  [form]
+  ;; TODO: this needs to check type hints, etc
+  (walk-node #(assoc % :box true) form))
+(defmethod set-box :reify
+  [form]
+  ;; TODO: this needs to check type hints, etc
+  (walk-node #(assoc % :box true) form))
+(defmethod set-box :method
+  [form]
+  (if (:box form)
+    (assoc-in form [:ret :box] true)
+    form))
+(defmethod set-box :dot
+  [form]
+  (assoc-in form [:target :box] true))
+(defmethod set-box :default
+  [form]
+  form)
 (defmulti exported (fn [attribute form] (:op form)))
       ;; Transform vars that represent classes into constants
       (instance? java.lang.Class o)
       (assoc form :op :constant :form o)
+      ;; Transform vars into a new :local op, and track references to them so we know what to capture when we create closures
-      (assoc form :referenced-locals #{{:name sym :type (expression-type form)}})
+      (let [form (assoc form :op :local)]
+        (assoc form :referenced-locals #{{:name sym :type (expression-type form)}}))
       (assoc form :vars #{sym}))))
+(defmethod collect-vars :local
+  [form]
+  (assoc form :referenced-locals #{{:name (-> form :info :name) :type (expression-type form)}}))
 (defmethod collect-vars :def
   (assoc form :vars #{(:name form)}))
               (str "No single method: " (:name meth) " of " class " found with arguments: " (:params meth)))))]
     (first matches)))
+(defmethod compute-type :constant
+  [form]
+  (assoc form :type (expression-type form)))
+(defmethod compute-type :var
+  [form]
+  (assoc form :type (expression-type form)))
+(defmethod compute-type :local
+  [form]
+  (assoc form :type (expression-type form)))
 (defmethod compute-type :method
   (if (:class form)
     (let [class (maybe-class (:class form))
           host-method (compute-host-method class form)]
-      (assoc form :host-method host-method :type (:return-type host-method)))
+      (assoc form :host-method host-method :type (maybe-class (:return-type host-method))))
+(defmethod compute-type :new
+  [{:as form :keys [ctor]}]
+  (assoc form :type (-> ctor :info :name resolve)))
 ;(defmethod compute-type :fn
   ; Symbol meta have a :tag?
   ; Var have a :tag?
   ; Find the correct overload in arglists, does it have a tag? )
-(def process-frames (ast-processor [set-unbox]
-                      [collect-constants collect-vars collect-callsites compute-type]))
+(def process-frames (ast-processor [set-box]
+                      [compute-type collect-constants collect-vars collect-callsites]))

File test/test/clojure/java/compiler.clj

+  (:refer-clojure :exclude [eval let fn reify])
   (:require [ :as c])
   (:use [clojure.test]))
 (in-ns '
-(deftest test-eval
+(definterface IPrimTester
+  (test [^int i])
+  (test [^java.lang.Integer i])
+  (test [^long l])
+  (test [^java.lang.Long l]))
+(defrecord PrimTester []
+  IPrimTester
+  (test [this ^int i] :int)
+  (test [this ^java.lang.Integer i] :Integer)
+  (test [this ^long l] :long)
+  (test [this ^java.lang.Long l] :Long))
+(defmacro type-of [v] `(.test (PrimTester.) ~v))
+(deftest primitives
+  ; This test is incorrect, eval is always boxed, type-of has to be inside the eval (is (= :long (type-of (c/eval '1))))
+  )
+(deftest eval
   (is (= 1 (c/eval '1)))
   (is (= java.lang.Object (c/eval 'java.lang.Object)))
   (testing "vector"
     (is (= 10 ((c/eval '(fn [x] (if (< x 10) (recur (inc x)) x))) 1)))
     (is (= 10 (c/eval '(loop [x 1] (if (< x 10) (recur (inc x)) x))))))
   (testing "do"
-    (is (= :success (c/eval '(do (+ 1 2) :success)))))
+    (is (= :success (c/eval '(do (+ 1 2) :success))))
+    (is (= 5 (c/eval '(do 1 {:a 2} 3 {:a 4} 5))) "Multiple sizes in do"))
   (is (instance? java.lang.Object (c/eval '(new java.lang.Object)))))
 (deftest let