tons of fixes and improvements from work on clojure-metal

src/mjolnir/constructors_init.clj

@@ -28,6 +28,9 @@
 (defn c-div [& exprs]
   (gen-binops :div exprs))
 
+(defn c-mod [& exprs]
+  (gen-binops :mod exprs))
+
 (defn c-and [& exprs]
   (gen-binops :and exprs))
 
@@ -110,6 +113,9 @@
 (defn c->= [a b]
   (exp/->Cmp :>= a b))
 
+(defn c-not= [a b]
+  (exp/->Cmp :not= a b))
+
 (defn c-dec [a]
   (c-+ a -1))
 
@@ -146,6 +152,9 @@
 (defn c-aget [arr idx]
   (exp/->AGet arr idx))
 
+(defn c-nth [arr idx]
+  (exp/->Nth arr idx))
+
 (defn c-eget [vec idx]
   (exp/->EGet vec idx))
 

src/mjolnir/core.clj

@@ -1,11 +1,13 @@
 (ns mjolnir.core
   (:require
+   [mjolnir.types :refer [Int64 Float64]]
+   [mjolnir.targets.target :refer [as-dll]]
    [mjolnir.expressions :as expr]
    [mjolnir.inference :refer [infer-all]]
    [mjolnir.validation :refer [validate]]
    [clojure.test :refer :all]
    [datomic.api :refer [q db] :as d]
-   [mjolnir.config :refer [*int-type* *target* default-target]]
+   [mjolnir.config :refer [*int-type* *float-type* *target* default-target]]
    [mjolnir.ssa :refer :all]
    [mjolnir.llvm-builder :refer [build dump optimize verify]]))
 
@@ -16,20 +18,47 @@
          nil)
         (get-plan conn)
         commit)
-    conn))
+    {:conn conn}))
 
-(defn to-llvm-module [conn]
+(defn to-llvm-module [{:keys [conn] :as ctx}]
   (infer-all conn)
   (validate (db conn))
   (let [built (build (db conn))]
-    #_(dump built)
     (verify built)
     (optimize built)
-    built))
+    #_(dump built)
+    (assoc ctx :module built)))
+
+(defn to-dll [{:keys [module] :as ctx}]
+  (assoc ctx :dll (as-dll (default-target) module {:verbose true})))
+
+(defn get-fn [{:keys [conn module dll]} ctr]
+  (let [nm (-> (ctr) :fnc :name)
+        _ (assert nm (str "Cant get name " nm))
+        db-val (db conn)
+        ent (ffirst (q '[:find ?id
+                        :in $ ?nm
+                        :where
+                        [?id :fn/name ?nm]]
+                      db-val
+                      nm))
+        _ (assert ent (str "Can't find " nm))
+        ent (d/entity db-val ent)]
+    (assert ent (pr-str "Can't find " nm))
+    (get dll ent)))
 
 (defn build-module [m]
   (-> (to-db m)
       (to-llvm-module)))
 
+(defn build-default-module [m]
+  (binding [*int-type* Int64
+            *float-type* Float64
+            *target* (default-target)]
+    (-> (to-db m)
+        (to-llvm-module)
+        (to-dll))))
+
+
 
 

src/mjolnir/expressions.clj

@@ -168,6 +168,7 @@
   {:+ :inst.binop.type/add
    :- :inst.binop.type/sub
    :* :inst.binop.type/mul
+   :mod :inst.binop.type/mod
    :div :inst.binop.type/div
    :and :inst.binop.type/and
    :or :inst.binop.type/or})
@@ -416,6 +417,17 @@
                                 :inst.arg/arg1 idx-id})]
      inst-id)))
 
+(defrecord Nth [arr idx]
+  SSAWriter
+  (write-ssa [this]
+    (gen-plan
+     [arr-id (write-ssa arr)
+      idx-id (write-ssa idx)
+      inst-id (add-instruction :inst.type/nth
+                               {:inst.arg/arg0 arr-id
+                                :inst.arg/arg1 idx-id})]
+     inst-id)))
+
 (defrecord Set [ptr member val]
   Validatable
   (validate [this]

src/mjolnir/inference.clj

@@ -7,45 +7,44 @@
             [clojure.core.logic.datomic :as ld]))
 
 (defn get-inferences [db]
-  (println "infering nodes...  ")
   (let [notype (ffirst (q '[:find ?id
                             :where
                             [?id :node/type :node.type/unknown]]
                           db))]
-    (time (concat (q '[:find ?id ?attr ?val
-                       :in $ % ?notype
-                       :where
-                       #_[?id :node/return-type ?notype]
-                       (infer-node ?id ?attr ?val)]
-                     db
-                     @rules
-                     notype)
-                  #_(q '[:find ?id ?attr ?val
-                       :in $ % ?notype
-                       :where
-                       #_[?id :node/return-type ?notype]
-                       (infer-cast-node ?id ?attr ?val)]
-                     db
-                     @rules
-                     notype)
-                  #_(q '[:find ?id ?attr ?val
-                       :in $ % ?notype
-                       :where
-                       #_[?id :node/return-type ?notype]
-                       (infer-binop-node ?id ?attr ?val)]
-                     db
-                     @rules
-                     notype)
-                  #_(->> (q '[:find ?id ?val
-                            :in $ %
-                            :where
-                            [?id :node/return-type ?notype]
-                            (infer-phi-return-type ?id ?val)]
-                          db
-                          @rules)
-                       (map
-                        (fn [[id val]]
-                          [id :node/return-type val])))))))
+    (concat (q '[:find ?id ?attr ?val
+                 :in $ % ?notype
+                 :where
+                 #_[?id :node/return-type ?notype]
+                 (infer-node ?id ?attr ?val)]
+               db
+               @rules
+               notype)
+            #_(q '[:find ?id ?attr ?val
+                   :in $ % ?notype
+                   :where
+                   #_[?id :node/return-type ?notype]
+                   (infer-cast-node ?id ?attr ?val)]
+                 db
+                 @rules
+                 notype)
+            #_(q '[:find ?id ?attr ?val
+                   :in $ % ?notype
+                   :where
+                   #_[?id :node/return-type ?notype]
+                   (infer-binop-node ?id ?attr ?val)]
+                 db
+                 @rules
+                 notype)
+            #_(->> (q '[:find ?id ?val
+                        :in $ %
+                        :where
+                        [?id :node/return-type ?notype]
+                        (infer-phi-return-type ?id ?val)]
+                      db
+                      @rules)
+                   (map
+                    (fn [[id val]]
+                      [id :node/return-type val]))))))
 
 (defn infer-all [conn]
   (let [db-val (db conn)
@@ -85,5 +84,12 @@
                (:node/type (:node/return-type ent))
                (:node/type (:node/return-type (:inst.arg/arg0 ent)))
                (:inst/type (:inst.arg/arg0 ent))
-               (:inst.gbl/name (:inst.arg/arg0 ent))]))))
+               (:inst.gbl/name (:inst.arg/arg0 ent))
+               (-> ent
+                   :inst/block
+                   :block/fn
+                   :fn/name)
+               (-> ent
+                   :inst/block
+                   :block/fn)]))))
         (assert false "inference fails")))))

src/mjolnir/llvm_builder.clj

@@ -351,7 +351,7 @@
     :inst.binop.type/sub :inst.binop.subtype/isub
     :inst.binop.type/mul :inst.binop.subtype/imul
     :inst.binop.type/div :inst.binop.subtype/idiv
-    :inst.binop.type/rem :inst.binop.subtype/irem
+    :inst.binop.type/mod :inst.binop.subtype/imod
     :inst.binop.type/and :inst.binop.subtype/and
     :inst.binop.type/or :inst.binop/subtype/or}
    :type/float
@@ -597,6 +597,24 @@
                                         (str "gep_" (:db/id inst)))]
                  (llvm/BuildLoad builder gep (str "load_" (:db/id inst))))))
 
+(defmethod build-instruction :inst.type/nth
+  [d module builder fn inst defs]
+  (unpack-args defs inst
+               [ptr idx]
+               (let [ptr-type (-> inst
+                                  :inst.arg/arg0
+                                  :node/return-type
+                                  :type/element-type
+                                  pointer-type-to
+                                  build-type)
+                     casted (llvm/BuildBitCast builder ptr ptr-type (str "casted_" (:db/id inst)))
+                     gep (llvm/BuildGEP builder
+                                        casted
+                                        (into-array Pointer [idx])
+                                        1
+                                        (str "gep_" (:db/id inst)))]
+                 gep)))
+
 (def cast-table
   {:inst.cast.type/fp-to-si llvm/LLVMFPToSI
    :inst.cast.type/si-to-fp llvm/LLVMSIToFP

src/mjolnir/ssa.clj

@@ -187,44 +187,41 @@
   "Commit processes the transaction with the associated connection, then updates all the tempids to match. You can then use plan-id to get the realized ent-ids"
   [{:keys [conn db new-ents updates valid-ids] :as plan}]
   (assert (and conn db))
-  (println "Writing to DB...")
-  (time
-   (let [ents (reduce
-               (fn [acc [ent id]]
-                 (assert (not (get acc id)) "Duplicate ids")
-                 (assoc acc id (assoc ent :db/id id)))
-               {}
-               new-ents)
-         _ (assert (= (set (keys ents))
-                      (set (keys valid-ids)))
-                   (pr-str (count (set (keys ents)))
-                           (count (set (keys valid-ids)))
-                           (count new-ents)))
-         data (-> (reduce
-                   (fn [acc [k attr val]]
-                     (assert (and k (get acc k)) (pr-str "Bad db-id given in update"
-                                                         k
-                                                         (get valid-ids k)
-                                                         " in "
-                                                         (keys valid-ids)))
-                     (assoc-in acc [k attr] val))
-                   ents
-                   updates)
-                  vals)
-         _ (println "Datoms to insert: " (reduce + (map count data)))
-         _ (println "Entities to insert: " (count data))
-         {:keys [db-before db-after tempids tx-data]}
-         @(d/transact conn data)
-         ptempids (zipmap
-                   (keys (:tempids plan))
-                   (map (partial d/resolve-tempid db-after tempids)
-                        (vals (:tempids plan))))]
-     (assoc plan
-       :tempids ptempids
-       :db db-after
-       :db-before db-before
-       :new-ents nil
-       :singletons nil))))
+  (let [ents (reduce
+              (fn [acc [ent id]]
+                (assert (not (get acc id)) "Duplicate ids")
+                (assoc acc id (assoc ent :db/id id)))
+              {}
+              new-ents)
+        _ (assert (= (set (keys ents))
+                     (set (keys valid-ids)))
+                  (pr-str (count (set (keys ents)))
+                          (count (set (keys valid-ids)))
+                          (count new-ents)))
+        data (-> (reduce
+                  (fn [acc [k attr val]]
+                    (assert (and k (get acc k)) (pr-str "Bad db-id given in update"
+                                                        k
+                                                        (get valid-ids k)
+                                                        " in "
+                                                        (keys valid-ids)))
+                    (assoc-in acc [k attr] val))
+                  ents
+                  updates)
+                 vals)
+
+        {:keys [db-before db-after tempids tx-data]}
+        @(d/transact conn data)
+        ptempids (zipmap
+                  (keys (:tempids plan))
+                  (map (partial d/resolve-tempid db-after tempids)
+                       (vals (:tempids plan))))]
+    (assoc plan
+      :tempids ptempids
+      :db db-after
+      :db-before db-before
+      :new-ents nil
+      :singletons nil)))
 
 (defn plan-id 
   [plan val]

src/mjolnir/ssa_rules.clj

@@ -4,7 +4,7 @@
 (def rules (atom []))
 
 (defmacro defrule [name args doc & body]
-  (println "Registered rule" name )
+  #_(println "Registered rule" name )
   (swap! rules conj `[(~name ~@args)
                       ~@body])
   nil)
@@ -139,7 +139,15 @@
   [?id :inst/type :inst.type/aget]
   [?id :inst.arg/arg0 ?arg0]
   (return-type ?arg0 ?arg0-t)
-  [?arg0-t :type/element-type ?type])
+  [?arg0-t :type/element-type ?type]
+  [?type :node/type ?nt])
+
+(defrule return-type [?id ?type]
+  "Nth returns the same type as the input"
+  [?id :inst/type :inst.type/nth]
+  [?id :inst.arg/arg0 ?arg0]
+  (return-type ?arg0 ?type))
+
 
 
 (defrule member-idx [?tp ?nm ?idx ?member-tp]

src/mjolnir/targets/darwin.clj

@@ -57,21 +57,21 @@
                       (:filename opts)
                       (:link-ops opts))]
       (println cmds)
-      (Thread/sleep 1000)
       (when (:verbose opts)
         (println "Linking: " cmds))
       (apply shell/sh cmds)
       (reify clojure.lang.ILookup
         (valAt [this key]
           (.valAt this key nil))
         (valAt [this key not-found]
-          (let [nm (-> (key) :fn)
+          (let [nm (-> key :fn/name)
+                _ (assert nm (str "Bad entity " key))
                 nfn (Function/getFunction (:filename opts)
-                                          (:name nm))
-                mj-ret (:ret-type (expr/return-type nm))
-                rettype (cond
-                         (types/integer-type? mj-ret) Integer
-                         (types/pointer-type? mj-ret) Pointer)]
+                                          nm)
+                mj-ret (-> key :fn/type :type.fn/return :node/type)
+                rettype (case mj-ret
+                          :type/int Integer
+                          :type/pointer Pointer)]
             (fn [& args]
               (.invoke nfn rettype (to-array args)))))))))