(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.order
"Make operand evaluation explicit before CFG construction. Calls and collection
construction consume immutable saved locals; source scopes stay unchanged."
(: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/defpass save
{:from [l/Ordered Expr] :to (t/HVec [l/Bound-Supply l/Ordered-Binding l/Ordered-Local])
:args [l/Bound-Supply] :body true}
[supply expr]
(let [[supply id] (source/fresh "operand" supply)
local {:id id :name id :mutable? false :external? false :jvm (:jvm expr)}]
[supply {:local local :init expr} local]))
(np/defpasses
(operands
{:from [l/Prepared Exprs]
:to (t/HVec [l/Bound-Supply (t/Vec l/Ordered-Binding) (t/Vec l/Ordered-Local)])
:args [l/Bound-Supply] :body true}
[supply exprs]
(reduce (fn [^{::t/- (t/HVec [l/Bound-Supply (t/Vec l/Ordered-Binding) (t/Vec l/Ordered-Local)])} acc
^{::t/- l/Prepared-Expr} expr]
(let [[supply bindings locals] acc
[supply expr] (normalize supply expr)
[supply binding local] (save supply expr)]
[supply (conj bindings binding) (conj locals local)])) [supply [] []] exprs))
(normalize-forms
{:from [l/Prepared Exprs] :to (t/HVec [l/Bound-Supply l/Ordered-Exprs])
:args [l/Bound-Supply] :body true}
[supply exprs]
(reduce (fn [^{::t/- (t/HVec [l/Bound-Supply l/Ordered-Exprs])} acc ^{::t/- l/Prepared-Expr} expr]
(let [[supply out] acc [supply expr] (normalize supply expr)] [supply (conj out expr)]))
[supply []] exprs))
(normalize-bindings
{:from [l/Prepared Bindings] :to (t/HVec [l/Bound-Supply l/Ordered-Bindings])
:args [l/Bound-Supply] :body true}
[supply bindings]
(reduce (fn [^{::t/- (t/HVec [l/Bound-Supply l/Ordered-Bindings])} acc ^{::t/- l/Prepared-Binding} binding]
(let [[supply out] acc [supply init] (normalize supply (:init binding))]
[supply (conj out (assoc binding :init init))])) [supply []] bindings))
(normalize-node
{:from [l/Prepared Node] :to (t/HVec [l/Bound-Supply l/Ordered-Expr])
:args [l/Bound-Supply l/Prepared-Expr]}
[supply expr node]
:literal [supply (assoc expr :node node)]
:local [supply (assoc expr :node node)]
:global [supply (assoc expr :node node)]
:var [supply (assoc expr :node node)]
:label [supply (assoc expr :node node)]
:goto [supply (assoc expr :node node)]
:native [supply (assoc expr :node node)]
:case (let [[supply selector] (normalize supply (:selector node))
[supply arms] (normalize-forms supply (:arms node))]
[supply (assoc expr :node {:op :case :selector selector :arms arms})])
:dispatch (let [[supply value] (normalize supply (:value node))
[supply binding local] (save supply value)]
[supply (assoc expr :node {:op :let :bindings [binding]
:body (assoc expr :node {:op :dispatch :value local :spec (:spec node)})})])
:recur (let [[supply bindings args] (operands supply (:args node))]
[supply (assoc expr :node {:op :let :bindings bindings
:body (assoc expr :node {:op :recur :target (:target node) :args args})})])
:loop (let [[supply bindings] (normalize-bindings supply (:bindings node))
[supply body] (normalize supply (:body node))]
[supply (assoc expr :node {:op :loop :id (:id node) :bindings bindings :body body})])
:if (let [[supply test] (normalize supply (:test node))
[supply yes] (normalize supply (:then node))
[supply no] (normalize supply (:else node))]
[supply (assoc expr :node {:op :if :test test :then yes :else no})])
:throw (let [[supply value] (normalize supply (:value node))]
[supply (assoc expr :node {:op :throw :value value})])
:write (let [[supply value] (normalize supply (:value node))]
[supply (assoc expr :node {:op :write :target (:target node) :value value})])
:do (let [[supply forms] (normalize-forms supply (:forms node))]
[supply (assoc expr :node {:op :do :forms forms})])
:let (let [[supply bindings] (normalize-bindings supply (:bindings node))
[supply body] (normalize supply (:body node))]
[supply (assoc expr :node {:op :let :bindings bindings :body body})])
:convert
(let [[supply value] (normalize supply (:value node))
[supply binding local] (save supply value)]
[supply (assoc expr :node {:op :let :bindings [binding]
:body (assoc expr :node {:op :convert :conversion (:conversion node) :value local})})])
:host-call
(let [[supply bindings args] (operands supply (:args node))]
[supply (assoc expr :node {:op :let :bindings bindings
:body (assoc expr :node {:op :host-call :operation (:operation node) :args args})})])
:invoke
(let [[supply function] (normalize supply (:function node))
[supply binding local] (save supply function)
[supply bindings args] (operands supply (:args node))]
[supply (assoc expr :node {:op :let :bindings (into [binding] bindings)
:body (assoc expr :node {:op :invoke :function local :args args})})])
:build
(let [[supply bindings items] (operands supply (:items node))
value (assoc expr :node {:op :build :kind (:kind node) :items items :unique? (:unique? node)})
[supply bindings value]
(if-let [metadata (:metadata node)]
(let [[supply binding local] (save supply value)
[supply metadata] (normalize supply metadata)
[supply meta-binding meta-local] (save supply metadata)]
[supply (into bindings [binding meta-binding])
(assoc expr :node {:op :metadata :value local :metadata meta-local})])
[supply bindings value])]
[supply (assoc expr :node {:op :let :bindings bindings :body value})]))
(normalize
{:from [l/Prepared Expr] :to (t/HVec [l/Bound-Supply l/Ordered-Expr])
:args [l/Bound-Supply] :body true}
[supply expr]
(normalize-node supply expr (:node expr))))
(np/defpass stage
{:from [l/Prepared Compilation] :to [l/Ordered Compilation] :body true}
[compilation]
(apply normalize compilation))