git » blacktide.git » master » tree

[master] / src / com / tailrecursion / blacktide / compiler / passes / boundaries.clj 

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.boundaries
  "Classify analyzed native bodies before expression lowering. Native subtrees
  exclude DSL effects; lowered loops materialize their source representations.
  Preserve separate boxing at Object uses of primitive source-local reads."
  (:require [com.tailrecursion.blacktide.compiler.passes.effects :refer [effects]]
            [com.tailrecursion.nanopass :as np]
            [com.tailrecursion.nanopass.pipeline :as pipeline]
            [com.tailrecursion.blacktide.compiler.languages :as l]
            [com.tailrecursion.blacktide.compiler.passes.loop-facts :as loops]
            [typed.clojure :as-alias t]))

(np/defpasses
  (native-node
    {:from [l/Bound Node] :to [l/Native Node]
     :processors {Expr native Exprs native-forms Binding native-binding
                  Local clojure.core/identity Raw clojure.core/identity CollectionKind clojure.core/identity
                  RecurTarget clojure.core/identity CaseSpec clojure.core/identity}}
    [node]
    :setq (if (empty? (:pairs node)) {:op :literal :value nil} (throw (IllegalStateException. "Native local write")))
    :psetq (if (empty? (:pairs node)) {:op :literal :value nil} (throw (IllegalStateException. "Native parallel write")))
    :label (throw (IllegalStateException. "Native label"))
    :goto (throw (IllegalStateException. "Native transfer")))

  (native-binding {:from [l/Bound Binding] :to [l/Native Binding] :body true}
    [binding] (assoc binding :init (native (:init binding))))

  (native-forms {:from [l/Bound Exprs] :to [l/Native Exprs] :processors {Expr native}}
    [forms])

  (native {:from [l/Bound Expr] :to [l/Native Expr] :body true}
    [expr]
    (assoc expr :node (native-node (:node expr)))))

(np/defpasses
  (classify-node
    {:from [l/Bound Node] :to [l/Classified Node]
     :processors {Expr classify Exprs classify-forms Binding classify-binding Assignments classify-pairs
                  Local clojure.core/identity RecurTarget clojure.core/identity
                  Raw clojure.core/identity CollectionKind clojure.core/identity CaseSpec clojure.core/identity}}
    [node])

  (classify-pair {:from [l/Bound Assignment] :to [l/Classified Assignment]
                            :processors {Expr classify Local clojure.core/identity}}
    [pair])

  (classify-pairs {:from [l/Bound Assignments] :to [l/Classified Assignments] :processors {Assignment classify-pair}}
    [pairs])

  (classify-binding {:from [l/Bound Binding] :to [l/Classified Binding]
                               :processors {Expr classify Local clojure.core/identity}}
    [binding])

  (classify-forms {:from [l/Bound Exprs] :to [l/Classified Exprs] :processors {Expr classify}}
    [forms])

  (classify {:from [l/Bound Expr] :to [l/Classified Expr] :body true}
    [expr]
    (let [node (:node expr)]
      (cond
        (and (= :loop (:op node)) (not (effects expr)))
        (assoc expr :node {:op :native :value (native expr)})
        (= :loop (:op node)) (let [expr (loops/lower expr)] (assoc expr :node (classify-node (:node expr))))
        :else
        (let [expr (assoc expr :node (classify-node node)) type (:type (:jvm expr))]
          ;; A machine slot must not turn separate Object uses of a primitive
          ;; source local into aliases of one box. Native bodies retain those
          ;; uses already; mutable locals have reference semantics.
          (if (and (= :local (:op (:node expr))) (:primitive? (:jvm expr))
                   (class? type) (.isPrimitive ^Class type) (not= Void/TYPE type))
            (assoc expr :node {:op :host :operation {:op :static :class clojure.lang.RT
                                                   :member (symbol (str (.getName ^Class type) "Cast")) :tags [type]}
                              :args [expr]}) expr))))))

(np/defpass stage
  {:from [l/Bound Compilation] :to [l/Classified Compilation] :body true}
  [compilation]
  (pipeline/map-value classify compilation))