(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.source
"Expand in the caller namespace while discovering lexical bindings. Macro
expansion and binding discovery stay ordered; every child becomes bound IR."
(:require [com.tailrecursion.blacktide.compiler.errors :as errors]
[com.tailrecursion.nanopass :as np]
[com.tailrecursion.blacktide.compiler.languages :as l]
[typed.clojure :as-alias t]
[com.tailrecursion.blacktide.compiler.jvm :as jvm]
[com.tailrecursion.blacktide.compiler.passes.source-jvm :as facts]
[com.tailrecursion.blacktide.compiler.passes.loop-facts :as loops]
[com.tailrecursion.blacktide.compiler.passes.source-case :as cases]
[com.tailrecursion.blacktide.compiler.passes.source-host :as host]))
(np/defpass fresh
{:from [l/Bound Supply] :to (t/HVec [l/Bound-Supply t/Sym]) :args [t/Str] :body true}
[stem supply]
;; Put the unique counter before the user-controlled stem. A source name
;; must not impersonate another binding's generated identity.
[(assoc supply :next (inc (:next supply))) (symbol (str (:prefix supply) "__" (:next supply) "__" stem))])
(np/defpass expression
{:from [l/Bound Node] :to [l/Bound Expr] :args [l/Bound-Context l/JVM-Seed] :body true}
[ctx jvm node]
{:site (:site ctx) :jvm (facts/infer jvm node) :node node})
(np/defpass resolve-name
{:from [l/Bound Raw] :to (t/U nil t/AnyVar java.lang.Class) :args [l/Bound-Context] :body true}
[ctx name]
(if (var? name) name
(when (and (symbol? name) (not (contains? (:locals ctx) name))) (ns-resolve *ns* name))))
(np/defpass parse-symbol
{:from [l/Bound Raw] :to [l/Bound Expr] :args [l/Bound-Context] :body true}
[ctx form]
(if (symbol? form)
(if-let [local (get (:locals ctx) form)]
(expression ctx {:hint (jvm/source-tag form) :var-meta {}} {:op :local :local local})
(let [resolved (resolve-name ctx form) qualified (host/qualified form)]
(cond
(var? resolved)
(let [m (or (meta resolved) {})]
(errors/check-visibility resolved (:site ctx))
(when (:macro m) (errors/fail :invalid-expression "Cannot take the value of a macro" {} (:site ctx)))
(if (:const m)
(expression ctx {:hint nil :var-meta {}} {:op :literal :value (.get ^clojure.lang.Var resolved)})
(expression ctx {:hint (jvm/source-tag form) :var-meta m}
{:op :global :name (.toSymbol ^clojure.lang.Var resolved)})))
(class? resolved) (expression ctx {:hint (jvm/source-tag form) :var-meta {}} {:op :literal :value resolved})
qualified
(let [operation qualified]
(expression ctx {:hint (jvm/source-tag form) :var-meta {}}
{:op :host :operation (if (= :static-field (:op operation)) operation
{:op :method-value :name form}) :args []}))
:else (errors/fail :unresolved-symbol "Unable to resolve symbol" {:binding form} (:site ctx)))))
(errors/fail :invalid-expression "Expected a symbol" {} (:site ctx))))
(np/defpass bind-local
{:from [l/Bound Raw] :to (t/HVec [l/Bound-Supply l/Bound-Context l/Bound-Local])
:args [l/Bound-Supply l/Bound-Context t/Bool l/JVM-Fact] :body true}
[supply ctx mutable? init name]
(if (simple-symbol? name)
(let [[supply id] (fresh (str name) supply)
jvm (facts/binding-facts name mutable? init)
type (:type jvm)
tag (or (:hint jvm) (when (class? type) (symbol (.getName ^Class type))))
local {:id id :name name :mutable? mutable? :external? false
:jvm jvm}]
[supply (assoc ctx :locals (assoc (:locals ctx) name local)
:macro-env (assoc (:macro-env ctx) name {:name name :tag tag})) local])
(errors/fail :invalid-binding "Binding targets must be simple symbols" {:binding name} (:site ctx))))
(np/defpass protocol-argument
{:from [l/Bound Expr] :to (t/HVec [l/Bound-Supply l/Bound-Expr])
:args [l/Bound-Supply l/Bound-Context l/Bound-Expr java.lang.Class] :body true}
[supply ctx direct? type arg]
(let [seed {:hint nil :var-meta {}} [supply id] (fresh "protocol-argument" supply)
local {:id id :name id :mutable? false :external? false :jvm (facts/binding-facts id false (:jvm arg))}
read (expression ctx seed {:op :local :local local})
boxed (expression ctx seed {:op :host :operation {:op :static :class clojure.lang.RT :member 'box :tags [Object]} :args [read]})
converted (if (.isPrimitive ^Class type)
(expression ctx seed {:op :host :operation {:op :static :class clojure.lang.RT :member 'box :tags [type]} :args [read]})
(expression ctx seed {:op :host :operation {:op :instance :class Class :member 'cast :mode :method :tags [Object]}
:args [(expression ctx seed {:op :literal :value type})
(expression ctx seed {:op :host :operation {:op :adapt :class type} :args [read]})]}))]
[supply (expression ctx seed {:op :let :bindings [{:local local :init arg}]
:body (expression ctx seed {:op :if :test direct? :then converted :else boxed})})]))
(np/defpass protocol-call
{:from [l/Bound Exprs] :to (t/HVec [l/Bound-Supply l/Bound-Expr])
:args [l/Bound-Supply l/Bound-Context l/JVM-Seed l/JVM-Protocol t/Sym] :body true}
[supply ctx seed method name args]
(let [plain {:hint nil :var-meta {}} [supply id] (fresh "protocol-receiver" supply)
receiver (expression ctx plain {:op :host :operation {:op :static :class clojure.lang.RT :member 'box :tags [Object]} :args [(nth args 0)]})
local {:id id :name id :mutable? false :external? false :jvm (:jvm receiver)}
read (expression ctx plain {:op :local :local local})
direct? (if-let [class (:class method)]
(expression ctx plain {:op :host :operation {:op :instanceof :class class} :args [read]})
(expression ctx plain {:op :literal :value false}))
root (expression ctx plain {:op :host :operation {:op :instance :class clojure.lang.Var :member 'getRawRoot :mode :method :tags []}
:args [(expression ctx plain {:op :var :name name})]})
root (expression ctx plain {:op :if :test direct? :then (expression ctx plain {:op :literal :value nil}) :else root})
[supply args] (reduce (fn [^{::t/- (t/HVec [l/Bound-Supply l/Bound-Exprs])} acc ^{::t/- t/Int} index]
(let [[supply out] acc arg (nth args index) type (get (:parameters method) (dec index) Object)
[supply arg] (if (= Object type) [supply arg] (protocol-argument supply ctx direct? type arg))]
[supply (conj out arg)])) [supply [read root]] (range 1 (count args)))]
[supply (expression ctx seed {:op :let :bindings [{:local local :init receiver}]
:body (expression ctx seed {:op :host :operation {:op :protocol :method method} :args args})})]))
(np/defpass parse-marker
{:from [l/Bound Forms] :to [l/Bound Expr] :args [l/Bound-Context (t/U ':label ':goto)] :body true}
[ctx kind forms]
(let [name (second forms)]
(when-not (and (= 2 (count forms)) (simple-symbol? name))
(errors/fail :invalid-marker "label/goto requires one simple symbol" {:label name} (:site ctx)))
(when-not (and (:statement? ctx) (:transfer? ctx) (or (= kind :goto) (:outer? ctx)))
(errors/fail :marker-position "Labels require the outer body; goto requires a statement outside operands and initializers"
{:operator kind :label name} (:site ctx)))
(expression ctx {:hint nil :var-meta {}}
(if (= kind :label) {:op :label :name name}
{:op :goto :name name}))))
(np/defpasses
(parse-operand
{:from [l/Bound Raw] :to (t/HVec [l/Bound-Supply l/Bound-Expr])
:args [l/Bound-Supply l/Bound-Context] :body true}
[supply ctx form]
(parse supply (assoc ctx :statement? false :tail? false :outer? false :transfer? false) form))
(parse-forms
{:from [l/Bound Forms] :to (t/HVec [l/Bound-Supply (t/Vec l/Bound-Expr)])
:args [l/Bound-Supply l/Bound-Context] :body true}
[supply ctx forms]
(reduce (fn [^{::t/- (t/HVec [l/Bound-Supply (t/Vec l/Bound-Expr)])} acc ^{::t/- l/Bound-Raw} form]
(let [[supply out] acc
last? (= (count out) (dec (count forms)))
ctx (assoc ctx :tail? (and (:tail? ctx) last?))
[supply expr] (if (:statement? ctx) (parse supply ctx form) (parse-operand supply ctx form))]
[supply (conj out expr)]))
[supply []] forms))
(parse-body
{:from [l/Bound Forms] :to (t/HVec [l/Bound-Supply l/Bound-Expr])
:args [l/Bound-Supply l/Bound-Context] :body true}
[supply ctx forms]
(let [[supply forms] (parse-forms supply (assoc ctx :statement? true) forms)]
[supply (expression ctx {:hint nil :var-meta {}} {:op :do :forms forms})]))
(parse-bindings
{:from [l/Bound Raw] :to (t/HVec [l/Bound-Supply l/Bound-Context (t/Vec l/Bound-Binding)])
:args [l/Bound-Supply l/Bound-Context (t/U ':mutable ':immutable ':loop)] :body true}
[supply ctx mode bindings]
(if (and (vector? bindings) (even? (count bindings)))
(reduce (fn [^{::t/- (t/HVec [l/Bound-Supply l/Bound-Context (t/Vec l/Bound-Binding)])} acc
^{::t/- (t/Seq t/Any)} pair]
(let [[supply ctx out] acc
[supply init] (parse-operand supply ctx (second pair))
[supply ctx local] (bind-local supply ctx (not= mode :immutable) (:jvm init) (first pair))
local (cond-> local (= mode :loop) (assoc :mutable? false))
ctx (assoc ctx :locals (assoc (:locals ctx) (:name local) local))
hint (jvm/tag-class (:hint (:jvm local)))
init (if (and hint (= mode :immutable))
(expression ctx {:hint nil :var-meta {}} {:op :host :operation {:op :adapt :class hint} :args [init]}) init)]
[supply ctx (conj out {:local local :init init})])) [supply ctx []] (partition 2 bindings))
(errors/fail :invalid-bindings "Expected an even binding vector" {} (:site ctx))))
(parse-scope
{:from [l/Bound Forms] :to (t/HVec [l/Bound-Supply l/Bound-Expr])
:args [l/Bound-Supply l/Bound-Context t/Bool] :body true}
[supply ctx mutable? forms]
(let [inner (assoc ctx :outer? mutable?)
[supply inner bindings] (parse-bindings supply inner (if mutable? :mutable :immutable) (second forms))
[supply body] (parse-body supply inner (vec (drop 2 forms)))]
[supply (expression ctx {:hint (jvm/source-tag (:form (:site ctx))) :var-meta {}}
{:op :let :bindings bindings :body body})]))
(parse-loop
{:from [l/Bound Forms] :to (t/HVec [l/Bound-Supply l/Bound-Expr])
:args [l/Bound-Supply l/Bound-Context] :body true}
[supply ctx forms]
(let [[supply id] (fresh "loop" supply)
inner (assoc ctx :outer? false :recur nil :tail? false)
[supply inner bindings] (parse-bindings supply inner :loop (second forms))
target {:id id :bindings (mapv :local bindings)}
[supply body] (parse-body supply (assoc inner :recur target :tail? true) (vec (drop 2 forms)))]
[supply (first (loops/solve {} (expression ctx {:hint nil :var-meta {}} {:op :loop :id id :bindings bindings :body body})))]))
(parse-recur
{:from [l/Bound Forms] :to (t/HVec [l/Bound-Supply l/Bound-Expr])
:args [l/Bound-Supply l/Bound-Context] :body true}
[supply ctx forms]
(let [target (:recur ctx)]
(when-not (and target (:tail? ctx))
(errors/fail :invalid-recur "recur requires the tail position of a local loop" {} (:site ctx)))
(when-not (= (count (:bindings target)) (dec (count forms)))
(errors/fail :recur-arity "recur argument count does not match its target" {} (:site ctx)))
(let [[supply args] (parse-forms supply (assoc ctx :statement? false :tail? false) (subvec forms 1))]
[supply (expression ctx {:hint nil :var-meta {}} {:op :recur :target target :args args})])))
(parse-arms
{:from [l/Bound Forms] :to (t/HVec [l/Bound-Supply l/Bound-Exprs])
:args [l/Bound-Supply l/Bound-Context] :body true}
[supply ctx forms]
(reduce (fn [^{::t/- (t/HVec [l/Bound-Supply l/Bound-Exprs])} acc ^{::t/- t/Any} form]
(let [[supply arms] acc [supply arm] (parse supply (assoc ctx :outer? false) form)] [supply (conj arms arm)]))
[supply []] forms))
(parse-case
{:from [l/Bound Forms] :to (t/HVec [l/Bound-Supply l/Bound-Expr])
:args [l/Bound-Supply l/Bound-Context] :body true}
[supply ctx forms]
(let [{:keys [selector arms]} (cases/expand-case (:macro-env ctx) forms)]
(if (empty? arms) (parse supply ctx selector)
(do
(when-not (and (seq? selector) (= 3 (count selector)))
(errors/fail :invalid-case "Expected core case's selector binding" {} (:site ctx)))
(let [[supply inner bindings] (parse-bindings supply ctx :immutable (second selector))
[supply selector] (parse-operand supply inner (first (nnext selector)))
[supply arms] (parse-arms supply inner arms)
body (expression ctx {:hint nil :var-meta {}}
{:op :case :selector (cases/compose-selector (count arms) selector) :arms arms})]
[supply (expression ctx {:hint nil :var-meta {}} {:op :let :bindings bindings :body body})])))))
(parse-dispatch
{:from [l/Bound Forms] :to (t/HVec [l/Bound-Supply l/Bound-Expr])
:args [l/Bound-Supply l/Bound-Context] :body true}
[supply ctx forms]
(let [{:keys [value spec arms]} (cases/dispatch-syntax forms)
[supply value] (parse-operand supply ctx value)]
(when-not (= :local (:op (:node value)))
(errors/fail :invalid-case "case* dispatch must reference a lexical local" {} (:site ctx)))
(let [selector (expression ctx {:hint nil :var-meta {}} {:op :dispatch :value value :spec spec})
[supply arms] (parse-arms supply ctx arms)]
[supply (expression ctx {:hint nil :var-meta {}} {:op :case :selector selector :arms arms})])))
(parse-call
{:from [l/Bound Forms] :to (t/HVec [l/Bound-Supply l/Bound-Expr])
:args [l/Bound-Supply l/Bound-Context] :body true}
[supply ctx forms]
(let [inner (assoc ctx :statement? false :tail? false)
[supply function] (parse-operand supply inner (first forms))
arity (dec (count forms))
direct (facts/direct-call arity function)
metadata (:var-meta (:jvm function))
primitive (when-not direct (facts/primitive-interface arity (:arglists metadata)))
hint (or (jvm/source-tag (:form (:site ctx)))
(jvm/source-tag (facts/signature arity (:arglists metadata)))
(when (and (not direct) (not primitive) (= :global (:op (:node function)))) (:hint (:jvm function)))
(:tag metadata))
[supply args] (parse-forms supply inner (vec (rest forms)))
class-arg (some-> args first :node)
node (cond
(and (= :global (:op (:node function))) (= 'clojure.core/instance? (:name (:node function)))
(= 2 (count args)) (= :literal (:op class-arg)) (class? (:value class-arg)))
{:op :host :operation {:op :instanceof :class (:value class-arg)} :args [(nth args 1)]}
direct {:op :host :operation direct :args args}
primitive {:op :host :operation {:op :instance :class primitive :member 'invokePrim :mode :method :tags nil}
:args (into [function] args)}
:else {:op :invoke :function function :args args})]
(let [method (when-not (or direct primitive) (facts/protocol-call arity function))
fnode (:node function) key (:form (:site function))]
(cond
(and method (= :global (:op fnode)))
(protocol-call supply ctx {:hint hint :var-meta {}} method (:name fnode) args)
(and (= :literal (:op fnode)) (keyword? key) (= 1 arity))
[supply (expression ctx {:hint hint :var-meta {}}
{:op :host :operation {:op :keyword :key key} :args args})]
:else [supply (expression ctx {:hint hint :var-meta {}} node)]))))
(parse-host
{:from [l/JVM Syntax] :to (t/HVec [l/Bound-Supply l/Bound-Expr])
:args [l/Bound-Supply l/Bound-Context] :body true}
[supply ctx syntax]
(let [[supply args] (parse-forms supply (assoc ctx :statement? false :tail? false) (:operands syntax))]
[supply (expression ctx {:hint (jvm/source-tag (:form (:site ctx))) :var-meta {}}
{:op :host :operation (:operation syntax) :args args})]))
(parse-assignment
{:from [l/Bound Forms] :to (t/HVec [l/Bound-Supply l/Bound-Expr])
:args [l/Bound-Supply l/Bound-Context (t/U ':setq ':psetq)] :body true}
[supply ctx kind forms]
(if (even? (count forms))
(let [[supply pairs]
(reduce (fn [^{::t/- (t/HVec [l/Bound-Supply l/Bound-Assignments])} acc ^{::t/- (t/Seq t/Any)} pair]
(let [[supply pairs] acc target (first pair)]
(when-not (simple-symbol? target)
(errors/fail :invalid-assignment "Assignment targets must be simple symbols" {:binding target} (:site ctx)))
(let [local (or (get (:locals ctx) target)
(errors/fail :unknown-assignment "Expected a mutable loophole local" {:binding target} (:site ctx)))]
(when-not (:mutable? local)
(errors/fail :immutable-assignment "Cannot assign to an immutable local" {:binding target} (:site ctx)))
(let [[supply value] (parse-operand supply ctx (second pair))]
[supply (conj pairs {:target local :value value})])))) [supply []] (partition 2 forms))]
[supply (expression ctx {:hint (jvm/source-tag (:form (:site ctx))) :var-meta {}}
(if (= kind :setq) {:op :setq :pairs pairs} {:op :psetq :pairs pairs}))])
(errors/fail :invalid-assignment "setq/psetq requires symbol/value pairs" {} (:site ctx))))
(parse-list
{:from [l/Bound Forms] :to (t/HVec [l/Bound-Supply l/Bound-Expr])
:args [l/Bound-Supply l/Bound-Context] :body true}
[supply ctx forms]
(let [op (first forms) form (:form (:site ctx)) resolved (resolve-name ctx op)
marker (when (var? resolved) (get (:markers ctx) resolved))
_ (when (var? resolved) (errors/check-visibility resolved (:site ctx)))]
(cond
(= :loophole marker)
(errors/fail :unsupported-form "Nested loophole regions are unsupported" {:operator op} (:site ctx))
(= :setq marker) (parse-assignment supply ctx :setq (vec (rest forms)))
(= :psetq marker) (parse-assignment supply ctx :psetq (vec (rest forms)))
(= :label marker) [supply (parse-marker ctx :label forms)]
(= :goto marker) [supply (parse-marker ctx :goto forms)]
(= op 'quote)
(if (= 2 (count forms))
[supply (expression ctx {:hint nil :var-meta {}} {:op :literal :value (second forms)})]
(errors/fail :invalid-quote "quote requires one argument" {} (:site ctx)))
(= op 'var)
(let [name (second forms) resolved (when (symbol? name) (ns-resolve *ns* name))]
(if (and (= 2 (count forms)) (var? resolved))
[supply (expression ctx {:hint nil :var-meta {}}
{:op :var :name (.toSymbol ^clojure.lang.Var resolved)})]
(errors/fail :invalid-var "var requires a resolvable Var name" {} (:site ctx))))
(#{'fn* 'letfn* 'try 'set! 'monitor-enter 'monitor-exit} op)
(errors/fail :unsupported-form "Form is unsupported inside loophole; place it outside the region" {:operator op} (:site ctx))
(#{'new '.} op) (parse-host supply ctx (or (host/syntax forms)
(errors/fail :invalid-interop "Missing host syntax" {} (:site ctx))))
(= op 'do) (parse-body supply ctx (vec (rest forms)))
(= op 'let*) (parse-scope supply ctx false forms)
(= op 'loop*) (parse-loop supply ctx forms)
(= op 'recur) (parse-recur supply ctx forms)
(= op 'case*) (parse-dispatch supply ctx forms)
(and (= resolved #'clojure.core/case) (< (count forms) 2))
(errors/fail :invalid-case "case requires a dispatch expression" {} (:site ctx))
(= resolved #'clojure.core/case) (parse-case supply ctx forms)
(= op 'if)
(if (<= 3 (count forms) 4)
(let [[supply test] (parse-operand supply ctx (second forms))
[supply yes] (parse supply (assoc ctx :outer? false) (nth forms 2))
[supply no] (parse supply (assoc ctx :outer? false) (get forms 3))]
[supply (expression ctx {:hint (jvm/source-tag form) :var-meta {}} {:op :if :test test :then yes :else no})])
(errors/fail :invalid-if "if requires a test, then, and optional else" {} (:site ctx)))
(= op 'throw)
(if (= 2 (count forms))
(let [[supply value] (parse-operand supply ctx (second forms))]
[supply (expression ctx {:hint nil :var-meta {}} {:op :throw :value value})])
(errors/fail :invalid-throw "throw requires one value" {} (:site ctx)))
(and (symbol? op) (special-symbol? op))
(errors/fail :unsupported-form "Special form is not supported inside loophole" {:operator op} (:site ctx))
(and (var? resolved) (:macro (meta resolved)))
(let [expanded (.applyTo ^clojure.lang.Var resolved (cons form (cons (:macro-env ctx) (rest forms))))
expanded (if (instance? clojure.lang.IObj expanded)
(with-meta expanded (merge (meta expanded) (meta form))) expanded)]
(parse supply ctx expanded))
(and (var? resolved) (ifn? (:inline (meta resolved)))
(let [arity (:inline-arities (meta resolved))] (or (nil? arity) (and (ifn? arity) (.invoke ^clojure.lang.IFn arity (dec (count forms)))))))
(let [inline (:inline (meta resolved))
expanded (if (ifn? inline) (.applyTo ^clojure.lang.IFn inline (rest forms))
(errors/fail :invalid-expression "Invalid inline expander" {} (:site ctx)))
expanded (if (instance? clojure.lang.IObj expanded)
(with-meta expanded (merge (meta expanded) (meta form))) expanded)]
(parse supply ctx expanded))
:else (if-let [syntax (host/syntax forms)]
(parse-host supply ctx syntax)
(parse-call supply ctx forms)))))
(parse-collection
{:from [l/Bound Raw] :to (t/HVec [l/Bound-Supply l/Bound-Expr])
:args [l/Bound-Supply l/Bound-Context] :body true}
[supply ctx form]
(if (or (vector? form) (map? form) (set? form))
(let [kind (cond (vector? form) :vector (map? form) :map :else :set)
;; Freeze source traversal before alpha-renaming changes element hashes.
items (if (map? form) (vec (mapcat identity form)) (vec form))
inner (assoc ctx :statement? false :tail? false)
[supply items] (parse-forms supply inner items)
[supply metadata] (if (some? (meta form)) (parse-operand supply inner (meta form)) [supply nil])]
[supply (expression ctx {:hint (jvm/source-tag form) :var-meta {}}
{:op :collection :kind kind :items items :metadata metadata})])
(errors/fail :invalid-expression "Expected a collection" {} (:site ctx))))
(parse
{:from [l/Bound Raw] :to (t/HVec [l/Bound-Supply l/Bound-Expr])
:args [l/Bound-Supply l/Bound-Context] :body true}
[supply ctx form]
(let [ctx (assoc ctx :site (errors/site (:site ctx) form))]
(cond
(symbol? form) [supply (parse-symbol ctx form)]
(and (seq? form) (seq form)) (parse-list supply ctx (vec form))
(or (vector? form) (map? form) (set? form))
(parse-collection supply ctx form)
:else [supply (expression ctx {:hint (jvm/source-tag form) :var-meta {}} {:op :literal :value form})]))))