git » blacktide.git » master » tree

[master] / src / com / tailrecursion / blacktide / compiler / passes / collections.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
78
79
80
81
82
83
(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.collections
  "Preserve native constant collections and construction checks. Metadata keeps
  construction dynamic and is evaluated only after that construction succeeds."
  (:require [com.tailrecursion.nanopass :as np]
            [com.tailrecursion.nanopass.pipeline :as pipeline]
            [com.tailrecursion.blacktide.compiler.languages :as l]
            [com.tailrecursion.blacktide.compiler.passes.host-emit :as host]
            [typed.clojure :as-alias t]))

(np/defpass constant
  {:from [l/Collections CollectionKind] :to t/Any :args [(t/Vec t/Any)] :body true}
  [values kind]
  (case kind
    :vector (vec values)
    :map (reduce (fn [^{::t/- (t/Map t/Any t/Any)} out ^{::t/- (t/Seq t/Any)} pair]
                   (assoc out (first pair) (second pair))) {} (partition 2 values))
    :set (set values)))

(np/defpass form
  {:from [l/Collections CollectionKind] :to [l/Machine Code]
   :args [(t/Vec l/Machine-Code) t/Bool] :body true}
  [items unique? kind]
  (if (= :vector kind)
    (if (<= (count items) 6)
      (list* 'clojure.lang.Tuple/create items)
      ;; An Object expression prevents constant folding without unboxing the
      ;; first item or changing its numeric width.
      (list 'do (assoc items 0 (host/box-form (nth items 0)))))
    (list (if (= :set kind) 'clojure.lang.RT/set
              (if unique? 'clojure.lang.RT/mapUniqueKeys 'clojure.lang.RT/map))
          (list 'clojure.lang.RT/object_array items))))

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

(np/defpass metadata-form
  {:from [l/Machine Code] :to [l/Machine Code] :args [l/Machine-Code] :body true}
  [value metadata]
  (let [v (gensym "value__") m (gensym "metadata__")]
    (list 'let* [(with-meta v {:tag 'clojure.lang.IObj}) value
                 (with-meta m {:tag 'clojure.lang.IPersistentMap}) metadata]
          (list '. v 'withMeta m))))

(np/defpasses
  (normalize-forms
    {:from [l/Assigned Exprs] :to [l/Collections Exprs] :processors {Expr normalize}}
    [forms])

  (normalize-node
    {:from [l/Assigned Node] :to [l/Collections Node]
     :processors {Expr normalize Exprs normalize-forms Binding normalize-binding Raw clojure.core/identity
                  Local clojure.core/identity RecurTarget clojure.core/identity CaseSpec clojure.core/identity}}
    [node]
    :collection
    (let [items (mapv normalize (:items node)) metadata (some-> (:metadata node) normalize)
          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")))
      (if (and (nil? metadata) values)
        {:op :literal :value (constant values (:kind node))}
        {:op :build :kind (:kind node) :items items :metadata metadata :unique? unique?})))

  (normalize-binding
    {:from [l/Assigned Binding] :to [l/Collections Binding]
     :processors {Expr normalize Local clojure.core/identity}}
    [binding])

  (normalize
    {:from [l/Assigned Expr] :to [l/Collections Expr] :body true}
    [expr]
    (assoc expr :node (normalize-node (:node expr)))))

(np/defpass stage
  {:from [l/Assigned Compilation] :to [l/Collections Compilation] :body true}
  [compilation]
  (pipeline/map-value normalize compilation))