(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.numeric-lower
"Realize numeric plans as primitive calls and explicit control. Saved operands
are already evaluated. Checks remain at the original operation; generic exits
retain their original overload, boxed identity and exception behavior."
(:require [com.tailrecursion.nanopass :as np]
[com.tailrecursion.blacktide.compiler.languages :as l]
[com.tailrecursion.blacktide.compiler.passes.numeric :as numeric]
[com.tailrecursion.blacktide.compiler.passes.value-facts :as facts]
[typed.clojure :as-alias t]))
(np/defpass operand
{:from [l/Compact Atom] :to [l/Compact Operand] :args [l/JVM-Type] :body true}
[type value]
{:value value :jvm {:type type :primitive? (and (class? type) (.isPrimitive ^Class type))
:hint nil :var-meta {} :hint-error nil}})
(np/defpass call
{:from [l/JVM Operation] :to [l/Compact Operand]
:args [(t/Vec l/Compact-Operand) java.lang.Class] :body true}
[args result operation]
;; Clojure only emits a few primitive widening conversions directly. Make
;; numeric promotions explicit instead of boxing a long to pass it as double.
(let [args (if-let [parameters (:tags operation)]
(mapv (fn [^{::t/- l/Compact-Operand} arg ^{::t/- t/Any} parameter]
(let [type (:type (:jvm arg))]
(if (and (not= type parameter)
(or (and (= Long/TYPE parameter) (contains? #{Byte/TYPE Short/TYPE Integer/TYPE} type))
(and (= Double/TYPE parameter) (contains? #{Byte/TYPE Short/TYPE Integer/TYPE Long/TYPE Float/TYPE} type))))
(call [arg] (if (= Long/TYPE parameter) (or Long/TYPE Long) (or Double/TYPE Double))
{:op :static :class clojure.lang.RT :member (if (= Long/TYPE parameter) 'longCast 'doubleCast)
:tags [(if (class? type) type Object)]}) arg))) args parameters) args)]
(operand result {:op :inline :type (when (.isPrimitive ^Class result) result)
:value {:op :host :operation operation :args args}})))
(np/defpass primitive
{:from [l/Numeric Plan] :to [l/Compact Operand]
:args [java.lang.Class t/Sym (t/Vec l/Compact-Operand)] :body true}
[owner member args plan]
(call args (:result plan) {:op :static :class owner :member member :tags (:parameters plan)}))
(np/defpass returned {:from [l/Compact Operand] :to [l/Compact Expr] :body true}
[value] {:op :return :values [(:value value)]})
(np/defpass branch
{:from [l/Compact Expr] :to [l/Compact Expr] :args [l/Compact-Operand l/Compact-Expr] :body true}
[test yes no] {:op :branch :test (:value test) :yes yes :no no})
(np/defpass nonzero
{:from [l/Compact Expr] :to [l/Compact Expr] :args [l/Compact-Operand java.lang.Class] :body true}
[divisor type body]
(let [test (call [divisor] (or Boolean/TYPE Boolean)
{:op :static :class clojure.lang.Numbers :member 'isZero :tags [type]})
error (call [(operand String {:op :literal :value "Divide by zero"})] ArithmeticException
{:op :constructor :class ArithmeticException :tags [String]})]
(branch test {:op :throw :value (:value error)} body)))
(np/defpass nan-returns
{:from [l/Compact Expr] :to [l/Compact Expr]
:args [(t/Vec l/Compact-Operand) (t/Vec java.lang.Class)] :body true}
[args parameters body]
(reduce (fn [^{::t/- l/Compact-Expr} out ^{::t/- t/Int} index]
(if (= Double/TYPE (nth parameters index))
(branch (call [(nth args index)] (or Boolean/TYPE Boolean)
{:op :static :class Double :member 'isNaN :tags [Double/TYPE]})
(returned (nth args index)) out) out))
body (reverse (range (count args)))))
(np/defpass recipe
{:from [l/Numeric Rhs] :to [l/Compact Expr]
:args [l/Numeric-Plan l/Represented-Types] :body true}
[plan types rhs]
(if (= :numeric (:op rhs))
(let [args (mapv (fn [^{::t/- l/Numeric-Operand} arg]
(let [type (facts/atom-type types (:value arg))]
(operand (if (class? type) type :unknown) (:value arg)))) (:args rhs))
owner (:class (:operation rhs)) member (:member (:operation rhs))
parameters (:parameters plan) result (:result plan)
direct (fn [] (primitive owner member args plan))]
(case (:recipe plan)
:call (returned (direct))
:compare (let [test (fn [relation]
(call args (or Boolean/TYPE Boolean)
{:op :static :class clojure.lang.Numbers :member relation :tags parameters}))
value (fn [n] {:op :return :values [{:op :literal :value n}]})]
(branch (test 'lt) (value -1) (branch (test 'gt) (value 1) (value 0))))
:widen-char (returned (call [(call args (or Integer/TYPE Integer)
{:op :static :class clojure.lang.RT :member 'intCast :tags [Character/TYPE]})]
result {:op :static :class clojure.lang.RT :member 'longCast :tags [Integer/TYPE]}))
(:negate-add :promoting-negate-add)
(let [promoting? (= :promoting-negate-add (:recipe plan))
unchecked? (= 'unchecked_minus member)
negative-type (if (and promoting? (= Long/TYPE (second parameters))) Number (or (second parameters) result))
negative (call [(nth args 1)] negative-type
{:op :static :class owner :member member :tags [(second parameters)]})]
(returned (call [(nth args 0) negative] result
{:op :static :class owner
:member (cond promoting? 'addP unchecked? 'unchecked_add :else 'add)
:tags [(first parameters) (if (= Number negative-type) Object negative-type)]})))
:zero-guard (nonzero (nth args 1) (or (second parameters) result) (returned (direct)))
:divide (nan-returns args parameters
(nonzero (nth args 1) (or (second parameters) result) (returned (direct))))
:select (nan-returns args parameters
(branch (call args (or Boolean/TYPE Boolean)
{:op :static :class owner :member (if (= 'max member) 'gt 'lt) :tags parameters})
(returned (nth args 0)) (returned (nth args 1))))
(:narrow-int :narrow-char :narrow-checked)
(let [char? (contains? '#{charCast uncheckedCharCast} member)
n (call args (or Long/TYPE Long)
{:op :static :class clojure.lang.RT :member (if char? 'uncheckedLongCast 'longCast) :tags [Double/TYPE]})
narrowed (call [n] result {:op :static :class clojure.lang.RT
:member (case member byteCast 'uncheckedByteCast shortCast 'uncheckedShortCast
charCast 'uncheckedCharCast member)
:tags [Long/TYPE]})]
(if (not= :narrow-checked (:recipe plan)) (returned narrowed)
(let [[lo hi] (case member byteCast [-128 127] shortCast [-32768 32767] charCast [0 65535])
original (call (:args rhs) (:return rhs) (assoc (:operation rhs) :tags (:parameters rhs)))
compare-bound (fn [relation bound]
(call [n (operand Long/TYPE {:op :literal :value bound})] (or Boolean/TYPE Boolean)
{:op :static :class clojure.lang.Numbers :member relation :tags [Long/TYPE Long/TYPE]}))]
(branch (compare-bound 'lt lo) (returned original)
(branch (compare-bound 'gt hi) (returned original) (returned narrowed))))))))
(throw (IllegalStateException. "Numeric recipe requires a recognized call"))))
(np/defpass expression {:from [l/Lexical Expr] :to [l/Compact Expr] :args [l/Represented-Types]}
[types node]
:bind (let [binding (:binding node) rhs (:value binding) target (:target binding)
body (expression types (:body node))
plan (numeric/plan types rhs)]
(if (and plan (numeric/applicable? types target plan rhs))
(let [value (recipe plan types rhs)
result (when (= :return (:op value)) (first (:values value)))]
(if (and result (= :inline (:op result)))
{:op :bind :binding {:target target :value (:value result)} :body body}
{:op :join :targets [target] :value value :body body}))
{:op :bind :binding {:target target :value (numeric/source-call rhs)} :body body}))
:join (assoc node :value (expression types (:value node)) :body (expression types (:body node)))
:branch (assoc node :yes (expression types (:yes node)) :no (expression types (:no node)))
:switch (assoc node :arms (mapv #(expression types %) (:arms node)))
:loop (assoc node :body (expression types (:body node)))
:recur node :return node :throw node)
(np/defpass program {:from [l/Lexical Program] :to [l/Compact Program] :body true}
[program] (assoc program :body (expression (:types program) (:body program))))