(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.source-jvm
"Infer source expression and binding facts before normalization erases native
typing evidence. Mutable locals use declared hints, never initializer guesses."
(:require [com.tailrecursion.nanopass :as np]
[com.tailrecursion.blacktide.compiler.languages :as l]
[com.tailrecursion.blacktide.compiler.jvm :as jvm]
[typed.clojure :as-alias t]))
(np/defpass signature
{:from [l/JVM Raw] :to (t/Option (t/Vec t/Any)) :args [t/Int] :body true}
[arity arglists]
(when-let [entries (when (or (seq? arglists) (vector? arglists)) (seq arglists))]
(let [sig (first entries)]
(if (and (vector? sig)
(or (= arity (count sig))
(let [offset (count (take-while #(not= '& %) sig))]
(and (< offset (count sig)) (<= offset arity)))))
sig
(signature arity (next entries))))))
(np/defpass primitive-interface
{:from [l/JVM Raw] :to (t/Option java.lang.Class) :args [t/Int] :body true}
[arity arglists]
(when-let [sig (signature arity arglists)]
(when (= arity (count sig))
(when-let [name (clojure.lang.Compiler$FnMethod/primInterface sig)]
(clojure.lang.RT/classForNameNonLoading name)))))
(np/defpass direct-call
{:from [l/Bound Expr] :to (t/Option l/JVM-Operation) :args [t/Int] :body true}
[arity function]
(let [node (:node function)]
(when (and (:direct-linking *compiler-options*) (= :global (:op node)))
(let [v (ns-resolve *ns* (:name node))]
(when (and (var? v) (not (.isDynamic ^clojure.lang.Var v))
(not (:redef (:var-meta (:jvm function)))) (.isBound ^clojure.lang.Var v))
(when-let [value (.get ^clojure.lang.Var v)]
(let [^Class class (.getClass ^Object value) members (.getMethods class)
selected (first (filter
(fn [^{::t/- java.lang.reflect.Method :tag java.lang.reflect.Method} member]
(let [params (jvm/parameters member)]
(and (= "invokeStatic" (.getName member))
(java.lang.reflect.Modifier/isStatic (.getModifiers member))
(or (= arity (count params))
(and (> arity (count params)) (= clojure.lang.ISeq (peek params)))))))
(mapv (fn [^{::t/- t/Int} index] (aget members (int index))) (range (alength members)))))]
(when selected
(let [params (jvm/parameters selected)]
{:op :direct :class class :parameters params :return (jvm/return-type selected)
:variadic? (= clojure.lang.ISeq (peek params))})))))))))
(np/defpass protocol-class {:from [l/JVM Raw] :to (t/Option java.lang.Class) :body true}
[on]
(when (or (class? on) (symbol? on)) (clojure.lang.Compiler$HostExpr/maybeClass on false)))
(np/defpass protocol-call
{:from [l/Bound Expr] :to (t/Option l/JVM-Protocol) :args [t/Int] :body true}
[arity function]
;; InvokeExpr reads protocol metadata after analyzing the operands. A macro
;; in an argument may change it; later source must not change this call.
(when (= :global (:op (:node function)))
(let [v (ns-resolve *ns* (:name (:node function)))
protocol (:protocol (meta v))]
(when protocol
(when-not (and (var? protocol) (pos? arity))
(throw (IllegalArgumentException. "A protocol call requires a protocol Var and receiver")))
(let [value (.get ^clojure.lang.Var protocol) class (protocol-class (:on value))]
(if class
(let [member (get (:method-map value) (keyword (name (:name (:node function)))))
methods (when (keyword? member) (jvm/methods class (dec arity) false (symbol member)))]
(when-not (and (keyword? member) (= 1 (count methods)))
(throw (IllegalArgumentException. "No single protocol interface method matches the call")))
{:class class :member (symbol (clojure.lang.Compiler/munge (str (symbol member))))
:parameters (jvm/parameters (first methods))})
{:class nil :member nil :parameters []}))))))
(np/defpass infer
{:from [l/Bound Node] :to [l/JVM Fact] :args [l/JVM-Seed] :body true}
[seed node]
(let [hint (when (#{:local :global :invoke :host} (:op node)) (jvm/tag-class (:hint seed)))
fact (fn ^{::t/- [l/JVM-Type t/Bool :-> l/JVM-Fact]} describe [type primitive?]
(jvm/fact primitive? seed (or hint type)))
inherited (fn ^{::t/- [l/JVM-Fact :-> l/JVM-Fact]} inherit [value]
(assoc (fact (:type value) (:primitive? value)) :hint-error (:hint-error value)))]
(case (:op node)
:literal (let [type (jvm/literal-type (:value node))]
(fact type (boolean (and (class? type) (.isPrimitive ^Class type)))))
:local (let [local (:jvm (:local node))]
(when (and hint (:primitive? local) (not= hint (:type local)))
(throw (UnsupportedOperationException. "Can't type hint a primitive local with a different type")))
(inherited local))
:global (fact (or hint (jvm/tag-class (:tag (:var-meta seed))) :unknown) false)
:var (fact clojure.lang.Var false)
:invoke (let [metadata (:var-meta (:jvm (:function node)))
sig (signature (count (:args node)) (:arglists metadata))]
(fact (or hint (jvm/tag-class (jvm/source-tag sig))
(when (= :global (:op (:node (:function node)))) (:type (:jvm (:function node))))
:unknown) false))
:host (let [operation (:operation node)
types (mapv #(jvm/value-type (:jvm %)) (:args node))
type (jvm/host-type types operation)
value (fact type (boolean (and (class? type) (.isPrimitive ^Class type)
(not (#{:adapt} (:op operation))))))]
(assoc value :hint-error (jvm/hint-conflict hint type)))
:collection (let [constant? (and (seq (:items node)) (nil? (:metadata node)) (every? #(= :literal (:op (:node %))) (:items node)))]
(case (:kind node)
:vector (if constant? (fact clojure.lang.APersistentVector false) (fact clojure.lang.IPersistentVector false))
:map (if constant? (fact clojure.lang.APersistentMap false) (fact clojure.lang.IPersistentMap false))
:set (if constant? (fact clojure.lang.APersistentSet false) (fact clojure.lang.IPersistentSet false))))
:if (let [a (:jvm (:then node)) b (:jvm (:else node))]
(assoc (fact (jvm/join-type (:type a) (:type b))
(and (:primitive? a) (:primitive? b) (= (:type a) (:type b))))
:hint-error (or (:hint-error a) (:hint-error b))))
:case (let [values (reduce (fn [^{::t/- (t/Vec l/JVM-Fact)} values ^{::t/- l/Bound-Expr} arm]
(if (= :throw (:op (:node arm))) values (conj values (:jvm arm)))) [] (:arms node))
type (some-> values first :type)
type (if (and (class? type) (every? #(and (= type (:type %)) (nil? (:hint-error %))) values)) type :unknown)]
(fact type (boolean (and (class? type) (.isPrimitive ^Class type)))))
:dispatch (fact Long/TYPE true)
:do (if-let [last (peek (:forms node))] (inherited (:jvm last)) (fact nil false))
:let (inherited (:jvm (:body node)))
:loop (fact :unknown false)
:recur (fact :unknown false)
:setq (if-let [last (peek (:pairs node))] (inherited (:jvm (:value last))) (fact nil false))
:psetq (fact nil false)
:label (fact nil false)
:goto (fact :unknown false)
:throw (fact :unknown false))))
(np/defpass binding-facts
{:from [l/JVM Fact] :to [l/JVM Fact] :args [l/JVM-Raw t/Bool] :body true}
[name mutable? init]
(let [hint (jvm/source-tag name) type (jvm/tag-class hint)]
(when-not mutable? (jvm/value-type init))
(when (and (not mutable?) hint (:primitive? init))
(throw (UnsupportedOperationException. "Can't type hint a local with a primitive initializer")))
(jvm/fact (and (not mutable?) (:primitive? init)) {:hint hint :var-meta {}}
(cond mutable? (or type :unknown)
(and (class? (:type init)) (.isPrimitive ^Class (:type init)) (not (:primitive? init))) :unknown
:else (or type (:type init))))))
(np/defpass caller-facts
{:from [l/JVM Raw] :to [l/JVM Fact] :args [t/Sym] :body true}
[name ^clojure.lang.Compiler$LocalBinding binding]
(if (instance? clojure.lang.Compiler$LocalBinding binding)
(jvm/fact (boolean (.getPrimitiveType binding)) {:hint (jvm/source-tag name) :var-meta {}}
(if (.hasJavaClass binding) (.getJavaClass binding) :unknown))
(jvm/fact false {:hint (jvm/source-tag name) :var-meta {}} (or (jvm/tag-class (jvm/source-tag name)) :unknown))))