(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.lower
"Lower ordered expressions into a CFG with explicit branch joins and exits.
Operands have explicit bindings; operations retain their execution position."
(:require [com.tailrecursion.blacktide.compiler.errors :as errors]
[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 fresh-block
{:from [l/Symbolic Builder] :to (t/HVec [l/Symbolic-Builder l/Symbolic-Label]) :body true}
[builder]
[(assoc builder :next (inc (:next builder))) (:next builder)])
(np/defpass start
{:from [l/Symbolic Label] :to [l/Symbolic Builder] :args [l/Symbolic-Builder] :body true}
[builder label]
(assoc builder :current label :ops []))
(np/defpass seal
{:from [l/Symbolic Term] :to [l/Symbolic Builder] :args [l/Symbolic-Builder] :body true}
[builder term]
(if (contains? (:blocks builder) (:current builder))
(throw (ex-info "Control-flow block already has a terminator" {:kind :invalid-graph :block (:current builder)}))
(assoc builder :blocks (assoc (:blocks builder) (:current builder) {:ops (:ops builder) :term term}) :ops [])))
(np/defpass evaluate
{:from [l/Symbolic Rhs] :to (t/HVec [l/Symbolic-Builder l/Symbolic-Atom])
:args [l/Symbolic-Builder] :body true}
[builder rhs]
(let [[supply id] (source/fresh "value" (:supply builder))]
[(-> builder (assoc :supply supply) (update :ops conj {:target id :value rhs})) {:op :local :id id}]))
(np/defpasses
(lower-forms
{:from [l/Ordered Exprs] :to (t/HVec [l/Symbolic-Builder l/Symbolic-Atom])
:args [l/Symbolic-Builder] :body true}
[builder forms]
(reduce (fn [^{::t/- (t/HVec [l/Symbolic-Builder l/Symbolic-Atom])} acc ^{::t/- l/Ordered-Expr} expr]
(lower (first acc) expr))
[builder {:op :literal :value nil}] forms))
(lower-bindings
{:from [l/Ordered Bindings] :to [l/Symbolic Builder] :args [l/Symbolic-Builder] :body true}
[builder bindings]
(reduce (fn [^{::t/- l/Symbolic-Builder} builder ^{::t/- l/Ordered-Binding} binding]
(let [[builder value] (lower builder (:init binding))]
(update builder :ops conj {:target (:id (:local binding)) :value {:op :value :value value}})))
builder bindings))
(lower-node
{:from [l/Ordered Node] :to (t/HVec [l/Symbolic-Builder l/Symbolic-Atom])
:args [l/Symbolic-Builder l/Ordered-Expr]}
[builder expr node]
:literal [builder {:op :literal :value (:value node)}]
:local (let [local (:local node)]
;; Ordered bindings already snapshot operands before later writes.
(if (:external? local) (evaluate builder {:op :external :name (:id local) :jvm (:jvm local)})
[builder {:op :local :id (:id local)}]))
:global (evaluate builder {:op :global :name (:name node)})
:var (evaluate builder {:op :var :name (:name node)})
:native (evaluate builder node)
:dispatch (evaluate builder {:op :dispatch :spec (:spec node)
:value {:value {:op :local :id (:id (:value node))} :jvm (:jvm (:value node))}})
:case
(let [[builder test] (lower builder (:selector node))
[builder join] (fresh-block builder)
[supply result] (source/fresh "case_result" (:supply builder))
[builder targets] (reduce (fn [^{::t/- (t/HVec [l/Symbolic-Builder (t/Vec l/Symbolic-Label)])} acc
^{::t/- l/Ordered-Expr} _]
(let [[builder targets] acc [builder label] (fresh-block builder)]
[builder (conj targets label)]))
[(assoc builder :supply supply) []] (:arms node))
builder (seal builder {:op :switch :test test :targets targets})
builder (reduce (fn [^{::t/- l/Symbolic-Builder} builder ^{::t/- t/Int} index]
(let [[builder value] (lower (start builder (nth targets index)) (nth (:arms node) index))]
(seal (update builder :ops conj {:target result :value {:op :value :value value}})
{:op :jump :target join}))) builder (range (count targets)))]
[(start builder join) {:op :local :id result}])
:loop (let [builder (lower-bindings builder (:bindings node))
[builder header] (fresh-block builder)
builder (assoc builder :loops (assoc (:loops builder) (:id node) header))]
(lower (start (seal builder {:op :jump :target header}) header) (:body node)))
:recur (let [target (:target node)
header (or (get (:loops builder) (:id target))
(errors/fail :invalid-graph "Missing source recur target" {} (:site expr)))
writes (mapv (fn [local arg] {:target (:id local) :value {:op :value :value {:op :local :id (:id arg)}}})
(:bindings target) (:args node))
builder (seal (update builder :ops into writes) {:op :jump :target header})
[builder next] (fresh-block builder)]
[(start builder next) {:op :literal :value nil}])
:if (let [[builder test] (lower builder (:test node))
[builder yes] (fresh-block builder) [builder no] (fresh-block builder) [builder join] (fresh-block builder)
[supply result] (source/fresh "join" (:supply builder))
builder (seal (assoc builder :supply supply) {:op :branch :test test :yes yes :no no})
[builder a] (lower (start builder yes) (:then node))
builder (seal (update builder :ops conj {:target result :value {:op :value :value a}}) {:op :jump :target join})
[builder b] (lower (start builder no) (:else node))
builder (seal (update builder :ops conj {:target result :value {:op :value :value b}}) {:op :jump :target join})]
[(start builder join) {:op :local :id result}])
:throw (let [[builder value] (lower builder (:value node))
builder (seal builder {:op :throw :value value})
[builder next] (fresh-block builder)]
[(start builder next) {:op :literal :value nil}])
:write (let [[builder value] (lower builder (:value node))]
[(update builder :ops conj {:target (:id (:target node)) :value {:op :value :value value}}) value])
:convert (evaluate builder {:op :convert :conversion (:conversion node)
:value {:value {:op :local :id (:id (:value node))} :jvm (:jvm (:value node))}})
:host-call (evaluate builder {:op :host :operation (:operation node)
:args (mapv (fn [local] {:value {:op :local :id (:id local)} :jvm (:jvm local)}) (:args node))})
:invoke (evaluate builder {:op :invoke :function {:op :local :id (:id (:function node))}
:args (mapv (fn [local] {:op :local :id (:id local)}) (:args node))})
:build (evaluate builder {:op :construct :kind (:kind node) :unique? (:unique? node)
:items (mapv (fn [local] {:op :local :id (:id local)}) (:items node))})
:metadata (evaluate builder {:op :metadata :value {:op :local :id (:id (:value node))}
:metadata {:op :local :id (:id (:metadata node))}})
:label (let [key (:name node)]
(when (contains? (:labels builder) key)
(errors/fail :duplicate-label "Duplicate label" {:label (:name node)} (:site expr)))
(let [[builder label] (fresh-block builder)
builder (assoc builder :labels (assoc (:labels builder) key label))
builder (seal builder {:op :jump :target label})]
[(start builder label) {:op :literal :value nil}]))
:goto (let [builder (seal builder {:op :transfer :name (:name node) :site (:site expr)})
[builder next] (fresh-block builder)]
[(start builder next) {:op :literal :value nil}])
:do (lower-forms builder (:forms node))
:let (lower (lower-bindings builder (:bindings node)) (:body node)))
(lower
{:from [l/Ordered Expr] :to (t/HVec [l/Symbolic-Builder l/Symbolic-Atom]) :args [l/Symbolic-Builder] :body true}
[builder expr]
(lower-node builder expr (:node expr))))
(np/defpass compile-graph
{:from [l/Ordered Expr] :to [l/Symbolic Program] :args [l/Bound-Supply] :body true}
[supply expr]
(let [[builder value] (lower {:supply supply :ops [] :next 1 :current 0 :blocks {} :labels {} :loops {}} expr)]
{:entry 0 :labels (:labels builder) :blocks (:blocks (seal builder {:op :return :value value}))}))
(np/defpass stage
{:from [l/Ordered Compilation] :to [l/Symbolic Program] :body true}
[compilation]
(apply compile-graph compilation))