diff --git a/src/mjolnir/constructors_init.clj b/src/mjolnir/constructors_init.clj index f9a367a..848dd1c 100644 --- a/src/mjolnir/constructors_init.clj +++ b/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)) diff --git a/src/mjolnir/core.clj b/src/mjolnir/core.clj index a340b3f..5182d2a 100644 --- a/src/mjolnir/core.clj +++ b/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)))) + + diff --git a/src/mjolnir/expressions.clj b/src/mjolnir/expressions.clj index a137da2..16ff58d 100644 --- a/src/mjolnir/expressions.clj +++ b/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] diff --git a/src/mjolnir/inference.clj b/src/mjolnir/inference.clj index 1e4f790..81e153b 100644 --- a/src/mjolnir/inference.clj +++ b/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"))))) diff --git a/src/mjolnir/llvm_builder.clj b/src/mjolnir/llvm_builder.clj index bb50b55..255ab42 100644 --- a/src/mjolnir/llvm_builder.clj +++ b/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 diff --git a/src/mjolnir/ssa.clj b/src/mjolnir/ssa.clj index d20dae5..3e57bde 100644 --- a/src/mjolnir/ssa.clj +++ b/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] diff --git a/src/mjolnir/ssa_rules.clj b/src/mjolnir/ssa_rules.clj index 74a4b0c..c3e561d 100644 --- a/src/mjolnir/ssa_rules.clj +++ b/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] diff --git a/src/mjolnir/targets/darwin.clj b/src/mjolnir/targets/darwin.clj index 4f8a76e..c1bcce1 100644 --- a/src/mjolnir/targets/darwin.clj +++ b/src/mjolnir/targets/darwin.clj @@ -57,7 +57,6 @@ (:filename opts) (:link-ops opts))] (println cmds) - (Thread/sleep 1000) (when (:verbose opts) (println "Linking: " cmds)) (apply shell/sh cmds) @@ -65,13 +64,14 @@ (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))))))))) diff --git a/src/mjolnir/types.clj b/src/mjolnir/types.clj index 0eda55c..dcbadec 100644 --- a/src/mjolnir/types.clj +++ b/src/mjolnir/types.clj @@ -57,15 +57,6 @@ " got: " (pr-str tp)))) (defrecord IntegerType [width] - Validatable - (validate [this] - (assure (integer? width))) - Type - (llvm-type [this] - (llvm/IntType width)) - ConstEncoder - (encode-const [this val] - (llvm/ConstInt (llvm-type this) val true)) IToPlan (add-to-plan [this] (gen-plan @@ -75,6 +66,11 @@ this)] this-id))) +(defrecord PlatformIntegerType [] + IToPlan + (add-to-plan [this] + (add-to-plan *int-type*))) + (defrecord VoidType [] Validatable @@ -322,6 +318,8 @@ (def Int8* (->PointerType (->IntegerType 8))) (def VoidT (->VoidType)) +(def IntT (->PlatformIntegerType)) + (def Float32 (->FloatType 32)) (def Float32* (->PointerType Float32)) (def Float32x4 (->VectorType Float32 4)) diff --git a/test/mjolnir/simple_tests.clj b/test/mjolnir/simple_tests.clj index 95d1508..c71ff73 100644 --- a/test/mjolnir/simple_tests.clj +++ b/test/mjolnir/simple_tests.clj @@ -12,7 +12,7 @@ [mjolnir.expressions :refer [->Fn ->Binop ->Arg ->If ->Call ->Gbl ->Cmp ->Let ->Local ->Loop ->Recur ->Free ->Malloc ->ASet ->AGet ->Do ->Module]] [mjolnir.constructors-init :refer [defnf]] - [mjolnir.core :refer [to-db to-llvm-module]]) + [mjolnir.core :refer [to-db to-llvm-module build-default-module get-fn]]) (:alias c mjolnir.constructors)) @@ -263,4 +263,15 @@ to-db to-llvm-module))) +(defnf test-dll [Int64 x -> Int64] + (+ x 1)) + + +(deftest compile-struct + (let [mod (-> (c/module ['mjolnir.simple-tests/test-dll]) + build-default-module) + f (get-fn mod test-dll)] + (is (= (f 42) 43)))) + +