(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.assignment
"Eliminate assignment batches. Sequential pairs become writes; parallel pairs
save all RHSs before writing. An abandoned RHS leaves pending writes undone."
(:require [com.tailrecursion.nanopass :as np]
[com.tailrecursion.blacktide.compiler.languages :as l]
[com.tailrecursion.blacktide.compiler.passes.source :as source]
[typed.clojure :as-alias t]))
(np/defpasses
(lower-forms
{:from [l/Classified Exprs] :to (t/HVec [l/Bound-Supply l/Assigned-Exprs])
:args [l/Bound-Supply] :body true}
[supply forms]
(reduce (fn [^{::t/- (t/HVec [l/Bound-Supply l/Assigned-Exprs])} acc ^{::t/- l/Classified-Expr} expr]
(let [[supply out] acc [supply expr] (lower supply expr)] [supply (conj out expr)]))
[supply []] forms))
(lower-bindings
{:from [l/Classified Bindings] :to (t/HVec [l/Bound-Supply l/Assigned-Bindings])
:args [l/Bound-Supply] :body true}
[supply bindings]
(reduce (fn [^{::t/- (t/HVec [l/Bound-Supply l/Assigned-Bindings])} acc ^{::t/- l/Classified-Binding} binding]
(let [[supply out] acc [supply init] (lower supply (:init binding))]
[supply (conj out (assoc binding :init init))])) [supply []] bindings))
(save-values
{:from [l/Classified Assignments]
:to (t/HVec [l/Bound-Supply l/Assigned-Bindings l/Assigned-Exprs]) :args [l/Bound-Supply] :body true}
[supply pairs]
(reduce (fn [^{::t/- (t/HVec [l/Bound-Supply l/Assigned-Bindings l/Assigned-Exprs])} acc
^{::t/- l/Classified-Assignment} pair]
(let [[supply bindings writes] acc [supply value] (lower supply (:value pair))
[supply id] (source/fresh "parallel" supply)
local {:id id :name id :mutable? false :external? false :jvm (:jvm value)}
read (assoc value :node {:op :local :local local})
write (assoc value :node {:op :write :target (:target pair) :value read})]
[supply (conj bindings {:local local :init value}) (conj writes write)])) [supply [] []] pairs))
(lower-node
{:from [l/Classified Node] :to (t/HVec [l/Bound-Supply l/Assigned-Node]) :args [l/Bound-Supply]}
[supply node]
:literal [supply node]
:local [supply node]
:global [supply node]
:var [supply node]
:label [supply node]
:goto [supply node]
:native [supply node]
:dispatch (let [[supply value] (lower supply (:value node))]
[supply {:op :dispatch :value value :spec (:spec node)}])
:case (let [[supply selector] (lower supply (:selector node))
[supply arms] (lower-forms supply (:arms node))]
[supply {:op :case :selector selector :arms arms}])
:recur (let [[supply args] (lower-forms supply (:args node))]
[supply {:op :recur :target (:target node) :args args}])
:loop (let [[supply bindings] (lower-bindings supply (:bindings node))
[supply body] (lower supply (:body node))]
[supply {:op :loop :id (:id node) :bindings bindings :body body}])
:if (let [[supply test] (lower supply (:test node))
[supply yes] (lower supply (:then node))
[supply no] (lower supply (:else node))]
[supply {:op :if :test test :then yes :else no}])
:throw (let [[supply value] (lower supply (:value node))] [supply {:op :throw :value value}])
:do (let [[supply forms] (lower-forms supply (:forms node))] [supply {:op :do :forms forms}])
:host (let [[supply args] (lower-forms supply (:args node))]
[supply {:op :host :operation (:operation node) :args args}])
:invoke (let [[supply function] (lower supply (:function node))
[supply args] (lower-forms supply (:args node))]
[supply {:op :invoke :function function :args args}])
:collection (let [[supply items] (lower-forms supply (:items node))
[supply metadata] (if-let [metadata (:metadata node)] (lower supply metadata) [supply nil])]
[supply {:op :collection :kind (:kind node) :items items :metadata metadata}])
:let (let [[supply bindings] (lower-bindings supply (:bindings node))
[supply body] (lower supply (:body node))]
[supply {:op :let :bindings bindings :body body}])
:setq (let [[supply values] (lower-forms supply (mapv :value (:pairs node)))]
[supply {:op :do :forms
(mapv (fn [pair value]
(assoc value :node {:op :write :target (:target pair) :value value}))
(:pairs node) values)}])
:psetq (let [[supply bindings writes] (save-values supply (:pairs node))
template (first writes)]
(if template
[supply {:op :let :bindings bindings
:body (assoc template :node {:op :do :forms (conj writes (assoc template :node {:op :literal :value nil}))})}]
[supply {:op :literal :value nil}])))
(lower
{:from [l/Classified Expr] :to (t/HVec [l/Bound-Supply l/Assigned-Expr])
:args [l/Bound-Supply] :body true}
[supply expr]
(let [[supply node] (lower-node supply (:node expr))] [supply (assoc expr :node node)])))
(np/defpass stage
{:from [l/Classified Compilation] :to [l/Assigned Compilation] :body true}
[compilation]
(apply lower compilation))