(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.structured-emit
"Emit lexical control with proven storage classes. Consumer source types stay
distinct from storage; Java argument conversions remain explicit evaluations.
Public exits carry an Object boundary without taking loops out of tail position."
(:require [com.tailrecursion.nanopass :as np]
[com.tailrecursion.blacktide.compiler.languages :as l]
[com.tailrecursion.blacktide.compiler.passes.compact :as compact]
[com.tailrecursion.blacktide.compiler.passes.collections :as collections]
[com.tailrecursion.blacktide.compiler.jvm :as jvm]
[typed.clojure :as-alias t]
[com.tailrecursion.blacktide.compiler.passes.emit :as emit]
[com.tailrecursion.blacktide.compiler.passes.host-emit :as host]
[com.tailrecursion.blacktide.compiler.passes.case-emit :as cases]))
(np/defpass primitive-form
{:from [l/Machine Code] :to [l/Machine Code] :args [java.lang.Class] :body true}
[^Class type form]
;; The parameter conversion is exactly the conversion previously performed by
;; RT.box(type); the matching primitive cast overload itself is an identity.
(list (with-meta (symbol "clojure.lang.RT" (str (.getName type) "Cast")) {:param-tags [type]}) form))
(np/defpass binding-form
{:from [l/Machine Code] :to [l/Machine Code] :args [l/Represented-Types t/Sym (t/Option java.lang.Class)] :body true}
[types id actual form]
(if-let [type (get types id)] (if (= type actual) form (primitive-form type form)) (host/box-form form)))
(np/defpasses
(atom-form {:from [l/Compact Atom] :to [l/Machine Code] :args [l/Compact-Types]}
[types node]
:local (:id node)
:literal (list 'quote (:value node))
:inline (rhs-form types (:value node)))
(operand-form
{:from [l/Compact Operand] :to [l/Machine Code] :args [l/Compact-Types] :body true}
[types operand]
(let [form (atom-form types (:value operand)) actual (compact/atom-type types (:value operand))
fact (:jvm operand)]
(if (and (class? actual) (= actual (:type fact))) form
(host/typed-form (assoc fact :primitive? false) (if (class? actual) (host/box-form form) form)))))
(rhs-form
{:from [l/Compact Rhs] :to [l/Machine Code] :args [l/Compact-Types]}
[types rhs]
:host (host/host-form (mapv #(operand-form types %) (:args rhs)) (:operation rhs))
:dispatch (cases/selector-form (operand-form types (:value rhs)) (:spec rhs))
:convert (let [conversion (:conversion rhs) operand (:value rhs)]
(if (and (:parameter? conversion) (.isPrimitive ^Class (:type conversion)))
(if (= (:type conversion) (compact/atom-type types (:value operand)) (:type (:jvm operand)))
(atom-form types (:value operand))
(primitive-form (:type conversion) (operand-form types operand)))
(host/conversion-form conversion (:jvm operand) (atom-form types (:value operand)))))
:value (atom-form types (:value rhs))
:global (emit/rhs-form rhs) :external (emit/rhs-form rhs) :var (emit/rhs-form rhs) :native (emit/rhs-form rhs)
:construct (collections/form (mapv #(atom-form types %) (:items rhs)) (:unique? rhs) (:kind rhs))
:metadata (collections/metadata-form (atom-form types (:value rhs)) (atom-form types (:metadata rhs)))
:invoke (list* (atom-form types (:function rhs)) (mapv #(atom-form types %) (:args rhs)))))
(np/defpass rhs-type
{:from [l/Compact Rhs] :to (t/Option java.lang.Class) :args [l/Compact-Types] :body true}
[types rhs]
(case (:op rhs)
:value (compact/atom-type types (:value rhs))
:convert (when (:parameter? (:conversion rhs)) (:type (:conversion rhs)))
:host (let [type (jvm/host-type (mapv #(:type (:jvm %)) (:args rhs)) (:operation rhs))]
(when (and (class? type) (not (#{:adapt} (:op (:operation rhs))))) type))
;; Other producers retain an explicit storage conversion.
nil))
(np/defpass operation-form
{:from [l/Compact Operation] :to [l/Machine Code] :args [l/Compact-Types] :body true}
[types op]
(binding-form types (:target op) (rhs-type types (:value op)) (rhs-form types (:value op))))
(np/defpasses
(let-form {:from [l/Compact Expr] :to [l/Machine Code] :args [l/Compact-Types t/Bool] :body true}
[types public? node]
((fn ^{::t/- [(t/Vec t/Any) l/Compact-Expr :-> l/Machine-Code]} bindings [pairs node]
(case (:op node)
:bind (let [op (:binding node)]
(recur (conj pairs (:target op) (operation-form types op)) (:body node)))
:join (let [targets (:targets node) value (expression types false (:value node))]
(case (count targets)
0 (list 'let* pairs (list 'do value (expression types public? (:body node))))
1 (recur (conj pairs (first targets) (binding-form types (first targets) nil value)) (:body node))
(let [packet (gensym "values__")]
(recur (into (conj pairs packet value)
(mapcat (fn [index id]
[id (binding-form types id nil (list 'clojure.lang.RT/nth packet index))])
(range) targets)) (:body node)))))
(list 'let* pairs (expression types public? node)))) [] node))
(expression {:from [l/Compact Expr] :to [l/Machine Code] :args [l/Compact-Types t/Bool]}
[types public? node]
:bind (let-form types public? node)
:effect (let [binding (:binding node) rhs (:value binding) type (get types (:target binding))
form (rhs-form types rhs)]
(list 'do (if (and type (not= type (rhs-type types rhs))) (primitive-form type form) form)
(expression types public? (:body node))))
:join (let-form types public? node)
:branch (list 'if (atom-form types (:test node)) (expression types public? (:yes node)) (expression types public? (:no node)))
:switch (cases/arms-form (mapv #(expression types public? %) (:arms node)) (atom-form types (:test node)))
:loop (list 'loop* (into [] (mapcat (fn [binding]
[(:target binding) (binding-form types (:target binding)
(compact/atom-type types (:value binding))
(atom-form types (:value binding)))])) (:bindings node))
(expression types public? (:body node)))
:recur (list* 'recur (mapv #(atom-form types %) (:args node)))
:return (let [values (:values node)]
(if (= 1 (count values))
(let [value (first values) form (atom-form types value)]
;; Tail compaction must retain the region's opaque result type.
(if (or public? (and (= :inline (:op value)) (= :native (:op (:value value)))))
(host/box-form form) form))
(if (seq values) (mapv #(atom-form types %) values) '(quote nil))))
:throw (let [form (list 'throw (atom-form types (:value node)))]
(if public? (host/box-form form) form))))