git » blacktide.git » master » tree

(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.host-emit
  "Emit host descriptors with source-typed saved operands. Known nil is retained
  explicitly; Object prevents boxed storage from inventing a more specific type."
  (:require [com.tailrecursion.nanopass :as np]
            [com.tailrecursion.blacktide.compiler.languages :as l]
            [typed.clojure :as-alias t]))

(np/defpass global-form {:from [l/Machine Name] :to [l/Machine Code] :body true}
  [name]
  ;; A later macro can change :const or :macro metadata after source analysis.
  (let [v (ns-resolve *ns* name)
        method (if (and (var? v) (.isDynamic ^clojure.lang.Var v)) 'get 'getRawRoot)]
    (list '. (list 'var name) method)))

(np/defpass box-form {:from [l/Machine Code] :to [l/Machine Code] :body true}
  [form]
  ;; Select Object explicitly: nil must not choose RT.box(Boolean), and callers
  ;; may supply genuine primitive locals that cannot accept an Object hint.
  (list (with-meta 'clojure.lang.RT/box {:param-tags ['java.lang.Object]}) form))

(np/defpass typed-form
  {:from [l/Machine Code] :to [l/Machine Code] :args [l/JVM-Fact] :body true}
  [fact form]
  (let [^Class type (:type fact)
        object-form (with-meta (if (symbol? form) form (apply list form)) {:tag 'java.lang.Object})]
    (cond
      (or (nil? type) (= Void/TYPE type)) (list 'do form nil)
      (and (class? type) (.isPrimitive type) (:primitive? fact))
      (list (with-meta (symbol "clojure.lang.RT" (str (.getName type) "Cast")) {:param-tags ['java.lang.Object]}) object-form)
      :else (with-meta (if (symbol? form) form (apply list form))
                       {:tag (if (class? type) (symbol (.getName type)) 'java.lang.Object)}))))

(np/defpass conversion-form
  {:from [l/Machine Code] :to [l/Machine Code] :args [l/JVM-Conversion l/JVM-Fact] :body true}
  [conversion fact form]
  (let [^Class type (:type conversion)]
    (cond
      (not (:parameter? conversion))
      ;; Validate the receiver before evaluating later operands.
      (list 'java.lang.Class/.cast (list 'quote type) (box-form form))
      (.isPrimitive type)
      (list (with-meta 'clojure.lang.RT/box {:param-tags [type]}) (typed-form fact form))
      :else
      (let [local (gensym "parameter__")]
        (list 'let* [(with-meta local {:tag (symbol (.getName type))})
                     (list (with-meta 'clojure.lang.RT/box {:param-tags ['java.lang.Object]}) form)]
              (list 'java.lang.Class/.cast (list 'quote type) local))))))


(np/defpass host-form
  {:from [l/JVM Operation] :to [l/Machine Code] :args [(t/Vec l/Machine-Code)]}
  [args operation]
  :keyword (list (:key operation) (first args))
  :protocol
  (let [locals (mapv (fn [_] (gensym "protocol__")) args)
        receiver (first locals) function (second locals) arguments (subvec locals 2)
        method (:method operation)
        fallback (list 'if (list 'clojure.core/or (list 'clojure.core/nil? function) (list 'clojure.core/instance? clojure.lang.IFn function))
                       (list* function receiver arguments)
                       (list 'throw (list 'new 'java.lang.IncompatibleClassChangeError "Protocol method root does not implement clojure.lang.IFn")))
        call (if-let [class (:class method)]
               (list 'if (list 'clojure.core/instance? class receiver)
                     (list* (with-meta (symbol (.getName ^Class class) (str "." (:member method))) {:param-tags (:parameters method)}) receiver arguments)
                     fallback) fallback)]
    ;; Even an invalid fallback root is checked only after all source operands.
    (list 'let* (vec (mapcat (fn [id value] [id (box-form value)]) locals args)) call))
  :direct (let [params (:parameters operation)
                fixed (if (:variadic? operation) (dec (count params)) (count params))
                args (if (:variadic? operation)
                       (conj (subvec args 0 fixed)
                             (list 'clojure.lang.ArraySeq/create (list 'clojure.lang.RT/object_array (subvec args fixed)))) args)]
            (list* (with-meta (symbol (.getName ^Class (:class operation)) "invokeStatic") {:param-tags params}) args))
  :instanceof (list 'clojure.core/instance? (:class operation) (first args))
  :adapt (let [local (gensym "hinted__")]
           (list 'let* [(with-meta local {:tag (symbol (.getName ^Class (:class operation)))}) (first args)] local))
  :method-value (:name operation)
  :static-field (symbol (.getName ^Class (:class operation)) (name (:member operation)))
  :constructor (if-let [tags (:tags operation)]
                 (list* (with-meta (symbol (.getName ^Class (:class operation)) "new") {:param-tags tags}) args)
                 (list* 'new (symbol (.getName ^Class (:class operation))) args))
  :static (list* (with-meta (symbol (.getName ^Class (:class operation)) (name (:member operation)))
                           (when-let [tags (:tags operation)] {:param-tags tags})) args)
  :instance (if-let [class (:class operation)]
              (list* (with-meta (symbol (.getName ^Class class) (str "." (:member operation)))
                               (when-let [tags (:tags operation)] {:param-tags tags})) args)
              (case (:mode operation)
                :method (list '. (first args) (list* (:member operation) (rest args)))
                :member (list '. (first args) (:member operation))
                :field (list '. (first args) (symbol (str "-" (:member operation)))))))