git » blacktide.git » master » tree

(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.native
  "Analyze native free reads and recover their source types from machine storage.
  Primitive source reads cannot observe the slot's box; reference reads retain
  it. Internal bindings keep native inference."
  (:require [clojure.set :as set]
            [com.tailrecursion.nanopass :as np]
            [com.tailrecursion.blacktide.compiler.languages :as l]
            [com.tailrecursion.blacktide.compiler.passes.collections :as collections]
            [com.tailrecursion.blacktide.compiler.passes.host-emit :as host]
            [com.tailrecursion.blacktide.compiler.passes.case-emit :as cases]
            [typed.clojure :as-alias t]))

(np/defpass literal-values {:from [l/Native Exprs] :to (t/Option (t/Vec t/Any)) :body true}
  [items]
  (reduce (fn [^{::t/- (t/Option (t/Vec t/Any))} values ^{::t/- l/Native-Expr} expr]
            (let [node (:node expr)]
              (if (and values (= :literal (:op node))) (conj values (:value node)) (reduced nil)))) [] items))

(np/defpass hinted-form {:from [l/Machine Code] :to [l/Machine Code] :args [l/JVM-Raw] :body true}
  [hint code]
  ;; Var return tags may be Class objects; source form tags cannot be.
  (let [hint (if (class? hint) (symbol (.getName ^Class hint)) hint)]
    (with-meta (if (symbol? code) code (apply list code))
               (cond-> (meta code) hint (assoc :tag hint)))))

(np/defpasses
  (bindings-form
    {:from [l/Native Bindings] :to (t/Vec t/Any) :args [(t/Set t/Sym)] :body true}
    [bound bindings]
    (into [] (mapcat (fn [^{::t/- l/Native-Binding} binding]
                   [(with-meta (:id (:local binding)) (meta (:name (:local binding))))
                    (form bound (:init binding))])) bindings))

  (node-form
    {:from [l/Native Node] :to [l/Machine Code] :args [(t/Set t/Sym) l/Native-Expr]}
    [bound expr node]
    :literal (list 'quote (:value node))
    :global (host/typed-form (:jvm expr) (host/global-form (:name node)))
    :var (list 'var (:name node))
    :local (let [local (:local node) id (:id local)]
             (if (contains? bound id)
               (with-meta id (when-let [hint (:hint (:jvm expr))] {:tag hint}))
               (host/typed-form (:jvm expr) (host/box-form id))))
    :host (hinted-form (:hint (:jvm expr)) (host/host-form (mapv #(form bound %) (:args node)) (:operation node)))
    :invoke (hinted-form (:hint (:jvm expr))
                        (list* (form bound (:function node)) (mapv #(form bound %) (:args node))))
    :if (list 'if (form bound (:test node)) (form bound (:then node)) (form bound (:else node)))
    :case (cases/arms-form (mapv #(form bound %) (:arms node)) (form bound (:selector node)))
    :dispatch (cases/selector-form (form bound (:value node)) (:spec node))
    :throw (list 'throw (form bound (:value node)))
    :do (list* 'do (mapv #(form bound %) (:forms node)))
    :recur (list* 'recur (mapv #(form bound %) (:args node)))
    :let (let [bound (into bound (map #(:id (:local %))) (:bindings node))]
           (list 'let* (bindings-form bound (:bindings node)) (form bound (:body node))))
    :loop (let [bound (into bound (map #(:id (:local %))) (:bindings node))]
            (list 'loop* (bindings-form bound (:bindings node)) (form bound (:body node))))
    :collection
    (let [items (:items node) metadata (:metadata node) values (literal-values items)
          keys (when (= :map (:kind node)) (literal-values (vec (take-nth 2 items))))
          unique? (boolean (and keys (= (count keys) (count (set keys)))))
          _ (when (and (nil? metadata) keys (not unique?))
              (throw (IllegalArgumentException. "Duplicate constant keys in map")))
          value (if (and (nil? metadata) values)
                  (list 'quote (collections/constant values (:kind node)))
                  (collections/form (mapv #(form bound %) items) unique? (:kind node)))]
      (if metadata (list '. value 'withMeta (form bound metadata)) value)))

  (form {:from [l/Native Expr] :to [l/Machine Code] :args [(t/Set t/Sym)] :body true}
    [bound expr] (node-form bound expr (:node expr))))

(np/defpasses
  (reads-node {:from [l/Native Node] :to (t/Set t/Sym)
                          :args [(t/Map t/Sym java.lang.Class)]}
    [types node]
    :literal #{} :global #{} :var #{}
    :local (if (:external? (:local node)) #{} #{(:id (:local node))})
    :host (into #{} (mapcat (partial boxed-reads types)) (:args node))
    :invoke (into (boxed-reads types (:function node)) (mapcat (partial boxed-reads types)) (:args node))
    :if (set/union (boxed-reads types (:test node)) (boxed-reads types (:then node)) (boxed-reads types (:else node)))
    :case (into (boxed-reads types (:selector node)) (mapcat (partial boxed-reads types)) (:arms node))
    :dispatch (boxed-reads types (:value node))
    :throw (boxed-reads types (:value node))
    :collection (into (if-let [metadata (:metadata node)] (boxed-reads types metadata) #{}) (mapcat (partial boxed-reads types)) (:items node))
    :do (into #{} (mapcat (partial boxed-reads types)) (:forms node))
    :recur (into #{} (mapcat (partial boxed-reads types)) (:args node))
    :let (set/difference (into (boxed-reads types (:body node)) (mapcat #(boxed-reads types (:init %))) (:bindings node))
                         (set (map #(get-in % [:local :id]) (:bindings node))))
    :loop (set/difference (into (boxed-reads types (:body node)) (mapcat #(boxed-reads types (:init %))) (:bindings node))
                          (set (map #(get-in % [:local :id]) (:bindings node)))))

  (boxed-reads {:from [l/Native Expr] :to (t/Set t/Sym)
                           :args [(t/Map t/Sym java.lang.Class)] :body true}
    [types expr]
    (let [node (:node expr) fact (:jvm expr)]
      (if (and (= :local (:op node)) (:primitive? fact)
               (= (:type fact) (get types (:id (:local node)))))
        #{} (reads-node types node)))))

(np/defpass reads {:from [l/Native Expr] :to (t/Set t/Sym) :body true}
  [expr] (boxed-reads {} expr))