├── src ├── clojure_py │ ├── .#nexpr_compiler.clj │ ├── compiler.py │ ├── system │ │ ├── .#pointer_dict.clj │ │ ├── integer.clj │ │ └── pointer_dict.clj │ ├── core.clj │ ├── analyzer.clj │ ├── compiler.clj │ ├── assembler.py │ ├── object.clj │ ├── benchmarks │ │ └── vectorize.clj │ ├── pyast.clj │ ├── nexpr_compiler.clj │ ├── constructors.clj │ └── llvmc.clj ├── user.clj └── cljs │ └── core.clj ├── test └── clojure_py │ ├── .#integer_tests.clj │ ├── .#llvmc_tests.clj │ ├── .#nexpr_compiler_tests.clj │ ├── core_test.clj │ ├── analyzer_test.clj │ ├── integer_tests.clj │ ├── pointer_dict_tests.clj │ ├── nexpr_compiler_tests.clj │ └── llvmc_tests.clj ├── README.md ├── scratch ├── build.sh └── benchmarks.c ├── doc └── intro.md └── project.clj /src/clojure_py/.#nexpr_compiler.clj: -------------------------------------------------------------------------------- 1 | tim@timbal.local.15685 -------------------------------------------------------------------------------- /test/clojure_py/.#integer_tests.clj: -------------------------------------------------------------------------------- 1 | tim@timbal.local.589 -------------------------------------------------------------------------------- /test/clojure_py/.#llvmc_tests.clj: -------------------------------------------------------------------------------- 1 | tim@timbal.local.12425 -------------------------------------------------------------------------------- /src/clojure_py/compiler.py: -------------------------------------------------------------------------------- 1 | (ns clojure-py.compiler 2 | ) 3 | -------------------------------------------------------------------------------- /src/clojure_py/system/.#pointer_dict.clj: -------------------------------------------------------------------------------- 1 | tim@timbal.local.589 -------------------------------------------------------------------------------- /test/clojure_py/.#nexpr_compiler_tests.clj: -------------------------------------------------------------------------------- 1 | tim@timbal.local.589 -------------------------------------------------------------------------------- /src/user.clj: -------------------------------------------------------------------------------- 1 | (ns user 2 | (:use [clojure.tools.namespace.repl] 3 | [clojure-py.constructors])) -------------------------------------------------------------------------------- /test/clojure_py/core_test.clj: -------------------------------------------------------------------------------- 1 | (ns clojure-py.core-test 2 | (:use clojure.test 3 | clojure-py.core)) 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | clojure-py-redux 2 | ================ 3 | 4 | A re-write of clojure-py using ClojureScript + Python ASTs -------------------------------------------------------------------------------- /scratch/build.sh: -------------------------------------------------------------------------------- 1 | 2 | 3 | clang `python-config --cflags --ldflags --libs` -O3 -shared benchmarks.c -o benchmarks.so 4 | -------------------------------------------------------------------------------- /src/clojure_py/core.clj: -------------------------------------------------------------------------------- 1 | (ns clojure-py.core) 2 | 3 | (defn foo 4 | "I don't do a whole lot." 5 | [x] 6 | (println x "Hello, World!")) 7 | -------------------------------------------------------------------------------- /doc/intro.md: -------------------------------------------------------------------------------- 1 | # Introduction to clojure-py 2 | 3 | TODO: write [great documentation](http://jacobian.org/writing/great-documentation/what-to-write/) 4 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject clojure-py "0.1.0-SNAPSHOT" 2 | :description "FIXME: write description" 3 | :url "http://example.com/FIXME" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :dependencies [[org.clojure/clojure "1.4.0"] 7 | [org.clojure/tools.namespace "0.2.2"] 8 | [net.java.dev.jna/jna "3.4.0"]]) 9 | -------------------------------------------------------------------------------- /test/clojure_py/analyzer_test.clj: -------------------------------------------------------------------------------- 1 | (ns clojure-py.analyzer-test 2 | #_(:use clojure.test 3 | clojure-py.alyzer)) 4 | (comment 5 | 6 | (def forms 7 | '[(+ 1 2)]) 8 | 9 | (defn debug [x] 10 | (println (pr-str x)) 11 | x) 12 | (defn make-test [form] 13 | (debug `(testing ~(str "can analyze " form) 14 | (is (analyze (list 'quote ~form)))))) 15 | 16 | (defmacro emit-forms [] 17 | (list* 'do 18 | (for [form forms] 19 | (make-test form)))) 20 | 21 | (deftest analyze-exprs 22 | (emit-forms))) -------------------------------------------------------------------------------- /src/clojure_py/system/integer.clj: -------------------------------------------------------------------------------- 1 | (ns clojure-py.system.integer 2 | (:require [clojure-py.constructors :refer :all] 3 | [clojure-py.object :as obj])) 4 | 5 | (defc-struct Winteger-t 6 | :extends obj/object-t 7 | :members [:int :value]) 8 | 9 | (defc-gbl Winteger-type-t -> obj/type-t 10 | ["Integer" 11 | obj/standard-obj-free]) 12 | 13 | (defc-fn from-int [:int num -> obj/object*] 14 | (-> (c-new Winteger-t (c-bitcast Winteger-type-t obj/type*) (const-int 1) num) 15 | (c-bitcast obj/object*))) 16 | 17 | (defc-fn unwrap-int [obj/object* i 18 | -> :int] 19 | (c-let [val (c-get i Winteger-t :value)] 20 | (c-call obj/dec-ref (c-bitcast i obj/object*)) 21 | val)) -------------------------------------------------------------------------------- /src/clojure_py/analyzer.clj: -------------------------------------------------------------------------------- 1 | (ns clojure-py.analyzer) 2 | 3 | 4 | (defn type->kw [form env] 5 | (cond (symbol? form) :symbol 6 | (integer? form) :int 7 | (seq? form) :seq)) 8 | 9 | (defmulti analyze-item type->kw) 10 | (defmulti analyze-sexp ffirst) 11 | 12 | 13 | 14 | 15 | (defmethod analyze-item :symbol 16 | [form env] 17 | "foo") 18 | (defmethod analyze-item :int 19 | [form env] 20 | {:env env 21 | :op :const 22 | :type :int 23 | :value :int}) 24 | 25 | (declare analyze-native) 26 | (defmethod analyze-item :seq 27 | [[f & args] env] 28 | (if (= (namespace f) "native") 29 | (analyze-native f args env)) 30 | #_{:env env 31 | :op :call 32 | :fn (analyze-item f env) 33 | :args (map analyze-item args env)}) 34 | 35 | 36 | (defn analyze [form] 37 | (analyze-item form {})) -------------------------------------------------------------------------------- /src/clojure_py/compiler.clj: -------------------------------------------------------------------------------- 1 | (ns clojure-py.compiler) 2 | 3 | (def third (comp second next)) 4 | 5 | (def to-ast) 6 | 7 | (defmulti -to-ast :op) 8 | (defmulti -native #(-> % :form second)) 9 | 10 | (defmethod -to-ast :js 11 | [form] 12 | (-native form)) 13 | 14 | (defmethod -to-ast :constant 15 | [{:keys [op env form]}] 16 | (cond (integer? form) {:op "Num" :args [form]} 17 | :else (assert false (str "Unknown form type" (type form))))) 18 | 19 | (defmethod -native "binop" 20 | [{:keys [children form]}] 21 | (let [op (third form)] 22 | {:op "BinOp" 23 | :args [(-to-ast (second children)) 24 | {:op op} 25 | (-to-ast (third children))]})) 26 | 27 | (defn to-ast [form] 28 | (let [f (-to-ast form) 29 | env (:env form)] 30 | (assoc f 31 | :line (:line env) 32 | :column (:column env)))) 33 | -------------------------------------------------------------------------------- /test/clojure_py/integer_tests.clj: -------------------------------------------------------------------------------- 1 | (ns clojure-py.integer-tests 2 | (:use clojure.test 3 | clojure-py.nexpr-compiler 4 | clojure.pprint) 5 | (:require [clojure-py.llvmc :as llvmc] 6 | [clojure-py.system.integer :as i] 7 | [clojure-py.constructors :refer :all] 8 | [clojure.pprint :refer [pprint]])) 9 | 10 | (defn dbg [p] 11 | (pprint p) 12 | p) 13 | 14 | (def main-fn-t (c-fn-t [:int :i8**] :int)) 15 | 16 | (deftest basic-integers 17 | (is (= (-> (c-module '[clojure-py.system.integer 18 | clojure-py.object] 19 | (c-fn "main" main-fn-t [argc argv] 20 | (c-call i/unwrap-int (c-call i/from-int (const-int 42))))) 21 | (dbg) 22 | (llvmc/compile-as-exe) 23 | (llvmc/run-exe) 24 | :exit) 25 | 42))) 26 | 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /src/clojure_py/assembler.py: -------------------------------------------------------------------------------- 1 | import json as json 2 | import ast 3 | import sys 4 | 5 | def err(s): 6 | sys.stderr.write(s) 7 | 8 | def _compile(form): 9 | err(str(form) + "\n") 10 | if type(form) == int: 11 | return form 12 | elif "args*" in form: 13 | obj = getattr(ast, form["op"]) 14 | args = map(_compile, form["args*"]) 15 | o = obj(args) 16 | o.body = args 17 | return o 18 | elif "args" in form: 19 | obj = getattr(ast, form["op"]) 20 | args = map(_compile, form["args"]) 21 | return obj(*args) 22 | else: 23 | obj = getattr(ast, form["op"]) 24 | return obj() 25 | 26 | def assemble(j): 27 | a = _compile(json.load(j)) 28 | err(ast.dump(a) + "\n") 29 | return json.dumps("baz!") 30 | 31 | def main(): 32 | print(assemble(sys.stdin)) 33 | 34 | 35 | if __name__ == "__main__": 36 | main() 37 | 38 | 39 | -------------------------------------------------------------------------------- /test/clojure_py/pointer_dict_tests.clj: -------------------------------------------------------------------------------- 1 | (ns clojure-py.pointer-dict-tests 2 | (:use clojure.test 3 | clojure-py.nexpr-compiler 4 | clojure.pprint) 5 | (:require [clojure-py.llvmc :as llvmc] 6 | [clojure-py.system.integer :as i] 7 | [clojure-py.system.pointer-dict :as p] 8 | [clojure-py.constructors :refer :all] 9 | [clojure.pprint :refer [pprint]])) 10 | 11 | (defn dbg [p] 12 | (pprint p) 13 | p) 14 | 15 | (def main-fn-t (c-fn-t [:int :i8**] :int)) 16 | 17 | (deftest can-create-and-add 18 | (is (= (-> (c-module '[clojure-py.system.pointer-dict 19 | clojure-py.object] 20 | (c-fn "main" main-fn-t [argc argv] 21 | (-> (p/new) 22 | (p/add-item (c-bitcast 42 :i8*) 23 | (c-bitcast 42 :i8*)) 24 | (p/-count)) 25 | 26 | )) 27 | #_(dbg) 28 | (llvmc/compile-as-exe) 29 | (llvmc/run-exe) 30 | :exit) 31 | 42))) 32 | -------------------------------------------------------------------------------- /src/cljs/core.clj: -------------------------------------------------------------------------------- 1 | (ns cljs.core 2 | (:refer-clojure :exclude [-> ->> .. amap and areduce alength aclone assert binding bound-fn case comment cond condp 3 | declare definline definterface defmethod defmulti defn defn- defonce 4 | defprotocol defrecord defstruct deftype delay destructure doseq dosync dotimes doto 5 | extend-protocol extend-type fn for future gen-class gen-interface 6 | if-let if-not import io! lazy-cat lazy-seq let letfn locking loop 7 | memfn ns or proxy proxy-super pvalues refer-clojure reify sync time 8 | when when-first when-let when-not while with-bindings with-in-str 9 | with-loading-context with-local-vars with-open with-out-str with-precision with-redefs 10 | satisfies? identical? true? false? nil? str get 11 | 12 | aget aset 13 | + - * / < <= > >= == zero? pos? neg? inc dec max min mod 14 | bit-and bit-and-not bit-clear bit-flip bit-not bit-or bit-set 15 | bit-test bit-shift-left bit-shift-right bit-xor]) 16 | (:require clojure.walk)) 17 | 18 | (alias 'core 'clojure.core) 19 | 20 | (defmacro + 21 | ([] 0) 22 | ([x] x) 23 | ([x y] (list 'js* "binop" "Add" x y)) 24 | ([x y & more] `(+ (+ ~x ~y) ~@more))) -------------------------------------------------------------------------------- /src/clojure_py/object.clj: -------------------------------------------------------------------------------- 1 | (ns clojure-py.object 2 | (:refer-clojure :exclude [defstruct]) 3 | (:use [clojure-py.constructors])) 4 | 5 | 6 | (defextern calloc [:int :int] :i8*) 7 | 8 | (def dealloc-fn-t 9 | {:type :fn 10 | :args [:i8*] 11 | :ret :int}) 12 | 13 | (def dealloc-fn-t* (c-pointer-t dealloc-fn-t)) 14 | 15 | (defc-struct type-t 16 | :members [:i8* :oname 17 | dealloc-fn-t* :dealloc-fn]) 18 | 19 | (def type* (c-pointer-t type-t)) 20 | 21 | (defc-struct object-t 22 | :members [type* :ob-type 23 | :int :ref-cnt]) 24 | 25 | 26 | (def object* (c-pointer-t object-t)) 27 | 28 | (defc-fn standard-obj-free [:i8* o -> :int] 29 | (c-free o) 30 | (const-int 0)) 31 | 32 | 33 | (defn ref-cnt [local] 34 | (c-get local object-t :ref-cnt)) 35 | 36 | (defn ob-type [local] 37 | (c-get local object-t :ob-type)) 38 | 39 | (defn dealloc-fn [tp] 40 | (c-get tp type-t :dealloc-fn)) 41 | 42 | (defc-fn dec-ref [object* local -> :int] 43 | (c-do (c-set local object-t :ref-cnt 44 | (c-idec (ref-cnt local))) 45 | (c-if (c-is (ref-cnt local) 46 | (const-int 0)) 47 | (c-do 48 | (c-call (dealloc-fn (ob-type local)) (c-bitcast local :i8*)) 49 | (const-int 0)) 50 | (ref-cnt local)))) 51 | 52 | (defn inc-ref [local] 53 | (c-let [nm (ref-cnt local)] 54 | (c-set local object-t :ref-cnt 55 | (c-iinc nm)) 56 | local)) 57 | 58 | (defn inc-refed [local] 59 | (c-do (inc-ref local) 60 | local)) 61 | 62 | (defn dec-refed [local] 63 | (c-do (dec-ref local) 64 | local)) 65 | 66 | 67 | -------------------------------------------------------------------------------- /test/clojure_py/nexpr_compiler_tests.clj: -------------------------------------------------------------------------------- 1 | (ns clojure-py.nexpr-compiler-tests 2 | (:use clojure.test 3 | clojure-py.nexpr-compiler 4 | clojure.pprint) 5 | (:require [clojure-py.llvmc :as llvmc])) 6 | 7 | (deftest testing-basic-exprs 8 | (is (native-code (nfn ^:extern clock [-> :int])))) 9 | 10 | (deftest build-simple-exe 11 | (is (= (-> (native-code (nfn main [:int argc :i8** argv -> :int] 12 | 42)) 13 | (debug) 14 | (llvmc/compile-as-exe) 15 | (llvmc/run-exe) 16 | :exit) 17 | 42)) 18 | (is (= (-> (native-code (nfn ^:extern strlen [:i8* str -> :int]) 19 | (nfn main [:int argc :i8** argv -> :int] 20 | (strlen (aget argv 1)))) 21 | (debug) 22 | (llvmc/compile-as-exe) 23 | (llvmc/run-exe "foo") 24 | :exit) 25 | 3)) 26 | (is (= (let [rgb-t {:type :struct 27 | :members [:int :int :int] 28 | :names [:r :g :b]}] 29 | (-> (native-code (nfn main [:int argc :i8** argv -> :int] 30 | (let [rgb (alloc rgb-t)] 31 | (set! rgb rgb-t :r 4) 32 | (set! rgb rgb-t :g 6) 33 | (set! rgb rgb-t :b 9) 34 | (iadd (get rgb rgb-t :r) 35 | (get rgb rgb-t :g) 36 | (get rgb rgb-t :b))))) 37 | (debug) 38 | (llvmc/compile-as-exe) 39 | (llvmc/run-exe) 40 | :exit)) 41 | 19))) 42 | -------------------------------------------------------------------------------- /src/clojure_py/benchmarks/vectorize.clj: -------------------------------------------------------------------------------- 1 | (ns clojure-py.benchmarks.vectorize) 2 | (comment 3 | 4 | (def clock-t :size_t) 5 | 6 | (def-nfn ^:extern clock []) 7 | (def-nfn ^:extern rand [:int max_val]) 8 | 9 | (def matrix-size 1000) 10 | 11 | (def-nfn rand-float [-> float] 12 | (fdiv (float (rand 10000)) 10000)) 13 | 14 | (def matrix-f-t {:type :array 15 | :etype {:type :array 16 | :etype :float 17 | :size matrix-size} 18 | :size matrix-size}) 19 | 20 | (def-nfn matrix-mul [matrix-f-t a 21 | matrix-f-t b 22 | matrix-f-t c 23 | -> int] 24 | (dotimes [i matrix-size 25 | j matrix-size 26 | k matrix-size] 27 | (aset c [i,j] 28 | (+ (aget c [i j]) 29 | (* (aget a [i j]) 30 | (aget b [j k])))))) 31 | 32 | (def-nfn init-matrix [matrix-f-t a 33 | -> :void] 34 | (dotimes [i matrix-size 35 | j matrix-size] 36 | (aset a [i j] (rand-float)))) 37 | 38 | (def-nfn zero-matrix [matrix-f-t a 39 | -> :void] 40 | (dotimes [i matrix-size 41 | j matrix-size] 42 | (aset a [i j] 0))) 43 | 44 | (def-nfn benchmark-matrix-f [-> :void] 45 | (dotimes [i 10] 46 | (let [a (malloc matrix-f-t) 47 | b (malloc matrix-f-t) 48 | c (malloc matrix-f t)] 49 | (init-matrix a) 50 | (init-matrix b) 51 | (zero-matrix c) 52 | (matrix-mul a b c) 53 | (free a b c)))) 54 | 55 | (def-nfn main [:int argc 56 | :i8** argv 57 | -> :int] 58 | (benchmark-matrix-f) 59 | 0)) -------------------------------------------------------------------------------- /src/clojure_py/pyast.clj: -------------------------------------------------------------------------------- 1 | (ns clojure-py.pyast 2 | #_(:require #_[clojure-python.core :as cljpy] 3 | [clojure.data.json :as json]) 4 | #_(:import [org.python.core PyObject PyList Py]) 5 | (:require [clojure.java.shell :as sh])) 6 | 7 | (comment 8 | (cljpy/init {:libpaths ["src/clojure_py/"]}) 9 | 10 | (cljpy/py-import-lib ast) 11 | (cljpy/py-import-lib __builtin__) 12 | 13 | (cljpy/py-import-lib assembler) 14 | (def assemble (cljpy/py-fn assembler assemble)) 15 | 16 | (defn ast-node [x] 17 | (let [f (.__finditem__ ast x)] 18 | (assert f (str "Could not find " x)) 19 | (fn [& args] 20 | (cljpy/call f args)))) 21 | 22 | 23 | (defn ast-node* [x] 24 | (let [f (.__finditem__ ast x)] 25 | (assert f (str "Could not find " x)) 26 | (fn [args] 27 | (println args "baaaazzz") 28 | (let [l (PyList. args)] 29 | (println l "<-- LLLLL" f args) 30 | (println (into-array PyObject [l]) 0) 31 | (let [v (.__call__ f 32 | (into-array PyObject []) 33 | (into-array String []))] 34 | (.__setattr__ v "body" l) 35 | v) 36 | )))) 37 | 38 | (defn ast-value [x] 39 | (.__finditem__ ast x)) 40 | 41 | (defn dump [a] 42 | (println a " --> " ((ast-node "dump") a)) 43 | a) 44 | 45 | (defn assemble [s] 46 | (let [{:keys [out err]} (sh/sh "python3" "src/clojure_py/assembler.py" :in s 47 | :out "UTF-8" 48 | )] 49 | (println "Errors: " err) 50 | out)) 51 | 52 | 53 | (defn compile [form] 54 | (let [r (assemble (json/write-str form))] 55 | (println r) 56 | (json/read-str r))) 57 | 58 | (defn run [form] 59 | (let [compiled (compile form)] 60 | (println compiled "<-- ") 61 | 3))) -------------------------------------------------------------------------------- /scratch/benchmarks.c: -------------------------------------------------------------------------------- 1 | #include "Python.h" 2 | 3 | static PyObject *simple_example(PyObject *self, PyObject *args) 4 | { 5 | PyObject *x; 6 | x = PyTuple_GetItem(args, 0); 7 | PyObject *zero = PyInt_FromLong(0); 8 | if (PyObject_RichCompareBool(x, zero, Py_EQ)) 9 | { 10 | Py_DECREF(args); 11 | return zero; 12 | } 13 | Py_DECREF(zero); 14 | 15 | PyObject *one = PyInt_FromLong(1); 16 | if (PyObject_RichCompareBool(x, one, Py_EQ)) 17 | { 18 | Py_DECREF(args); 19 | return one; 20 | } 21 | Py_DECREF(one); 22 | 23 | PyObject *minusone = PyInt_FromLong(-1); 24 | PyObject *minustwo = PyInt_FromLong(-2); 25 | 26 | PyObject *leftnum = PyNumber_Add(x, minusone); 27 | PyObject *rightnum = PyNumber_Add(x, minustwo); 28 | 29 | Py_DECREF(args); 30 | Py_DECREF(minusone); 31 | Py_DECREF(minustwo); 32 | 33 | PyObject *leftargs = PyTuple_Pack(1, leftnum); 34 | PyObject *rightargs = PyTuple_Pack(2, rightnum); 35 | 36 | PyObject *left = simple_example(self, leftargs); 37 | PyObject *right = simple_example(self, rightargs); 38 | 39 | 40 | Py_DECREF(leftargs); 41 | Py_DECREF(rightargs); 42 | 43 | PyObject *ret = PyNumber_Add(left, right); 44 | 45 | Py_DECREF(left); 46 | Py_DECREF(right); 47 | 48 | return ret; 49 | 50 | 51 | } 52 | 53 | 54 | PyObject *_call_optimized_example(PyObject *); 55 | 56 | static PyObject *call_optimized_example(PyObject *self, PyObject *args) 57 | { 58 | PyObject *x; 59 | x = PyTuple_GetItem(args, 0); 60 | return _call_optimized_example(x); 61 | } 62 | 63 | PyObject *_call_optimized_example(PyObject *x) 64 | { 65 | PyObject *zero = PyInt_FromLong(0); 66 | if (PyObject_RichCompareBool(x, zero, Py_EQ)) 67 | { 68 | Py_DECREF(x); 69 | return zero; 70 | } 71 | Py_DECREF(zero); 72 | 73 | PyObject *one = PyInt_FromLong(1); 74 | if (PyObject_RichCompareBool(x, one, Py_EQ)) 75 | { 76 | Py_DECREF(x); 77 | return one; 78 | } 79 | Py_DECREF(one); 80 | 81 | PyObject *minusone = PyInt_FromLong(-1); 82 | PyObject *minustwo = PyInt_FromLong(-2); 83 | 84 | PyObject *leftnum = PyNumber_Add(x, minusone); 85 | PyObject *rightnum = PyNumber_Add(x, minustwo); 86 | 87 | Py_DECREF(x); 88 | Py_DECREF(minusone); 89 | Py_DECREF(minustwo); 90 | 91 | PyObject *left = _call_optimized_example(leftnum); 92 | PyObject *right = _call_optimized_example(rightnum); 93 | 94 | PyObject *ret = PyNumber_Add(left, right); 95 | 96 | Py_DECREF(left); 97 | Py_DECREF(right); 98 | 99 | return ret; 100 | 101 | 102 | } 103 | 104 | 105 | long _type_hinted_example(long x); 106 | static PyObject *type_hinted_example(PyObject *self, PyObject *args) 107 | { 108 | PyObject *x; 109 | x = PyTuple_GetItem(args, 0); 110 | return PyInt_FromLong(_type_hinted_example(PyInt_AsLong(x))); 111 | } 112 | 113 | long _type_hinted_example(long x) 114 | { 115 | if (x == 0) return 0; 116 | if (x == 1) return 1; 117 | return _type_hinted_example(x - 1) + _type_hinted_example(x - 2); 118 | } 119 | 120 | 121 | static PyMethodDef ExampleMethods[] = { 122 | 123 | {"simple_example", simple_example, METH_VARARGS, "A simple (slow) example"}, 124 | {"call_optimized_example", call_optimized_example, METH_VARARGS, "A slightly optimized version"}, 125 | {"type_hinted_example", type_hinted_example, METH_VARARGS, "Fully Optimized"}, 126 | {NULL, NULL, 0, NULL} 127 | 128 | 129 | }; 130 | 131 | 132 | PyMODINIT_FUNC 133 | initbenchmarks (void) 134 | { 135 | (void) Py_InitModule("benchmarks", ExampleMethods); 136 | } 137 | -------------------------------------------------------------------------------- /src/clojure_py/system/pointer_dict.clj: -------------------------------------------------------------------------------- 1 | (ns clojure-py.system.pointer-dict 2 | (:require [clojure-py.constructors :refer :all] 3 | [clojure-py.object :as obj])) 4 | 5 | 6 | (defc-struct entry-t 7 | :members [:int :k 8 | obj/object* :v]) 9 | 10 | (def entry* (c-pointer-t entry-t)) 11 | 12 | (defc-struct pointer-dict-t 13 | :members [:int :count 14 | :int :size 15 | :int :mask 16 | entry* :table]) 17 | 18 | (def pointer-dict* (c-pointer-t pointer-dict-t)) 19 | 20 | (defc-fn new [-> pointer-dict*] 21 | (c-new pointer-dict-t 0 256 7 (-> (obj/calloc 16 256) 22 | (c-bitcast entry*)))) 23 | 24 | (defc-fn slot-free? [entry* table :int idx -> :bool] 25 | (c-is (-k (c-aget table idx)) (const-int 0))) 26 | 27 | (defc-fn probe-1 [entry* table 28 | :int idx 29 | :int hash 30 | :int perturb 31 | :int mask 32 | -> entry*] 33 | (c-let [i (c-iadd (c-shl idx (const-int 2)) 34 | idx 35 | perturb 36 | (const-int 1))] 37 | (c-let [newidx (c-and i mask)] 38 | (c-if (c-call slot-free? table idx) 39 | (c-aget table idx) 40 | (c-recur table newidx hash (c-shr perturb (const-int 5)) mask))))) 41 | 42 | (defc-fn find-free [entry* table :int hash :int mask -> entry*] 43 | (c-let [idx (c-and hash mask)] 44 | (c-if (slot-free? table idx) 45 | (c-aget table idx) 46 | (probe-1 table idx hash hash mask)))) 47 | 48 | (defc-fn inc-table-count [pointer-dict* dict 49 | -> pointer-dict*] 50 | ;; TODO: Resize full dicts 51 | (c-set dict pointer-dict-t :count (c-iadd (-count dict) (const-int 1)))) 52 | 53 | 54 | (defc-fn found-item? [entry* table :int idx :int k -> :i1] 55 | (c-is (-k (c-aget table idx)) k)) 56 | 57 | (defc-fn find-probe-1 [entry* table 58 | :int idx 59 | :int hash 60 | :int perturb 61 | :int mask 62 | -> entry*] 63 | (c-let [i (c-iadd (c-shl idx (const-int 2)) 64 | idx 65 | perturb 66 | (const-int 1)) 67 | newidx (c-and i mask)] 68 | (c-if (found-item? table newidx hash) 69 | (c-aget table newidx) 70 | (c-if (slot-free? table newidx) 71 | (c-nptr entry*) 72 | (c-recur table newidx hash (c-shr perturb (const-int 5)) mask))))) 73 | 74 | (defc-fn add-item [pointer-dict* dict 75 | :i8* ptr 76 | obj/object* obj 77 | -> pointer-dict*] 78 | (c-let [k (c-bitcast ptr :int) 79 | entry (find-free (-table dict) k (-mask dict))] 80 | (c-set entry entry-t :k k) 81 | (c-set entry entry-t :v obj) 82 | (inc-table-count dict))) 83 | 84 | 85 | 86 | (defc-fn find-item [entry* table :int hash :int mask -> entry*] 87 | (c-let [idx (c-and hash mask)] 88 | (c-if (slot-free? table idx) 89 | (c-nptr entry*) 90 | (c-if (found-item? table idx hash) 91 | (c-aget table idx) 92 | (find-probe-1 table idx hash hash mask))))) 93 | 94 | (defc-fn get-item [pointer-dict* dict 95 | :i8* ptr 96 | obj/object* default 97 | -> obj/object*] 98 | (let [k (c-bitcast ptr :int) 99 | entry (find-item (-table dict) k (-mask dict))])) 100 | 101 | 102 | 103 | 104 | -------------------------------------------------------------------------------- /src/clojure_py/nexpr_compiler.clj: -------------------------------------------------------------------------------- 1 | (ns clojure-py.nexpr-compiler) 2 | 3 | (def ^:dynamic *locals*) 4 | (def ^:dynamic *globals*) 5 | 6 | (defn type->kw [form] 7 | (cond (symbol? form) :symbol 8 | (integer? form) :int 9 | (seq? form) :seq)) 10 | 11 | (defmulti analyze-item type->kw) 12 | (defmulti analyze-sexp #(first %)) 13 | 14 | (defmethod analyze-item :default 15 | [f] 16 | (assert false (str "Can't analyze: " f))) 17 | 18 | (defmethod analyze-item :symbol 19 | [sym] 20 | (if-let [op (*locals* sym)] 21 | op 22 | {:op :global 23 | :name (name sym)})) 24 | 25 | (defmethod analyze-sexp :default 26 | [[nm & args]] 27 | {:op :call 28 | :fn {:op :global 29 | :name (name nm)} 30 | :args (mapv analyze-item args)}) 31 | 32 | (defmethod analyze-item :seq 33 | [itm] 34 | (analyze-sexp itm)) 35 | 36 | (defmethod analyze-item :int 37 | [itm] 38 | {:op :const 39 | :type :int 40 | :value itm}) 41 | 42 | (defmethod analyze-sexp 'deftype 43 | [[_ nm v]] 44 | (swap! *globals* assoc nm v)) 45 | 46 | (defmethod analyze-sexp 'float 47 | [[_ expr]] 48 | {:op :cast 49 | :type :float 50 | :body expr}) 51 | 52 | (defmethod analyze-sexp 'let 53 | [[_ binds & body]] 54 | (let [[nm b & more] binds] 55 | {:op :let 56 | :name nm 57 | :value (analyze-item b) 58 | :body (binding [*locals* (assoc *locals* 59 | nm {:op :local :name nm})] 60 | (if more 61 | (analyze-item (list* 'let (vec more) body)) 62 | {:op :do 63 | :body (mapv analyze-item body)}))})) 64 | 65 | (defmethod analyze-sexp 'fdiv 66 | [[_ & ops]] 67 | (reduce 68 | (fn [a x] 69 | {:op :fdiv 70 | :div a 71 | :num x}) 72 | (analyze-item (first ops)) 73 | (next ops))) 74 | 75 | (defmethod analyze-sexp 'aset 76 | [[_ arr idx v]] 77 | {:op :aset 78 | :idx (map analyze-item idx) 79 | :arr (analyze-item arr) 80 | :value (analyze-item v)}) 81 | 82 | (defmethod analyze-sexp 'aget 83 | [[_ arr idx]] 84 | (let [idx (if (vector? idx) idx [idx])] 85 | {:op :aget 86 | :idx (map analyze-item idx) 87 | :ptr (analyze-item arr)})) 88 | 89 | (defmethod analyze-sexp 'fadd 90 | [[_ & ops]] 91 | (reduce 92 | (fn [a x] 93 | {:op :fadd 94 | :a a 95 | :b (analyze-item x)}) 96 | (analyze-item (first ops)) 97 | (next ops))) 98 | 99 | (defmethod analyze-sexp 'fmul 100 | [[_ & ops]] 101 | (reduce 102 | (fn [a x] 103 | {:op :fmul 104 | :a a 105 | :b (analyze-item x)}) 106 | (analyze-item (first ops)) 107 | (next ops))) 108 | 109 | 110 | (defn- inner-dotimes [[local max-val] body-fn] 111 | (assert (symbol? local) "Local must be a symbol") 112 | (let [sname (gensym (str (name local) "_max_"))] 113 | {:op :let 114 | :locals [[sname (analyze-item local)]] 115 | :body {:op :loop 116 | :locals [local] 117 | :inits [{:op :const 118 | :type :int 119 | :value 0}] 120 | :body {:op :do 121 | :body (binding [*locals* (assoc *locals* local)] 122 | [(body-fn) 123 | {:op :if 124 | :test {:op :eq 125 | :a {:op :local :name local} 126 | :b {:op :local :name sname}} 127 | :then {:op :const 128 | :type :int 129 | :value 0} 130 | :else {:op :recur 131 | :locals [{:op :iadd 132 | :a {:op :local 133 | :name local} 134 | :b {:op :const 135 | :type :int 136 | :value 1}}]}}])}}})) 137 | 138 | (defn- outer-dotimes [b body] 139 | (if b 140 | (inner-dotimes (first b) 141 | #(outer-dotimes (next b) body)) 142 | (analyze-sexp (list 'do body)))) 143 | 144 | (defmethod analyze-sexp 'dotimes 145 | [[_ b & body]] 146 | (let [binds (partition 2 b)] 147 | (outer-dotimes binds body))) 148 | 149 | (defmethod analyze-sexp 'nfn 150 | [[_ nm args & body]] 151 | (let [args (partition 2 args) 152 | ret-fn (comp (partial = '->) first) 153 | ret-type (second (first (filter ret-fn args))) 154 | args (remove ret-fn args) 155 | args-map (zipmap (map second args) 156 | (range)) 157 | arg-types (mapv first args)] 158 | (assert ret-type "Function must return a type (use -> type)") 159 | {:op :fn 160 | :type {:type :fn 161 | :args arg-types 162 | :ret ret-type} 163 | :name (name nm) 164 | :args (map second args) 165 | :body (when body 166 | {:op :do 167 | :body (binding 168 | [*locals* 169 | (zipmap (map last args) 170 | (map (fn [idx] 171 | {:op :arg 172 | :idx idx}) 173 | (range))) 174 | *globals* (atom {})] 175 | (mapv analyze-item 176 | body))}) 177 | :linkage (when (:extern (meta nm)) :external)})) 178 | 179 | (defn- parse-fn [name args body]) 180 | 181 | (defn debug [x] 182 | (println x) 183 | x) 184 | 185 | (defmacro def-nfn 186 | [name args & body] 187 | (debug `(def ~name (analyze-item ~(list 'quote (list* 'nfn name args body)))))) 188 | 189 | (defmacro native-code 190 | [& body] 191 | (debug `(map analyze-item ~(list 'quote body)))) 192 | -------------------------------------------------------------------------------- /test/clojure_py/llvmc_tests.clj: -------------------------------------------------------------------------------- 1 | (ns clojure-py.llvmc-tests 2 | (:use clojure.test 3 | clojure-py.llvmc 4 | clojure.pprint)) 5 | 6 | (init-target) 7 | 8 | (deftest llvm-type-test 9 | (is (llvm-type {:type :struct 10 | :members [:long :int {:type :array 11 | :size 20 12 | :etype {:type :struct 13 | :members [:int :int :i8*]}}]})) 14 | (is (llvm-type {:type :fn 15 | :ret :long 16 | :args [:long {:type :array 17 | :size 20 18 | :etype :int}]}))) 19 | 20 | (deftest llvm-encode-consts 21 | (is (encode-const (llvm-type :int) 42)) 22 | (is (encode-const (llvm-type {:type :struct 23 | :members [:int :long]}) 24 | [42 43])) 25 | (is (encode-const (llvm-type {:type :struct 26 | :members [:int {:type :array 27 | :etype :long 28 | :size 3}]}) 29 | [42 [1 2 3]])) 30 | (is (encode-const (llvm-type {:type :array 31 | :size 1 32 | :etype {:type :fn* 33 | :args [] 34 | :ret :int}}) 35 | [nil])) 36 | (is (encode-const (llvm-type :i8*) 37 | "footon")) 38 | (is (encode-const (llvm-type {:type :array 39 | :size 1 40 | :etype {:type :struct 41 | :members [:i8*]}}) 42 | [["footon"]]))) 43 | 44 | 45 | (pprint (target-seq)) 46 | 47 | (deftest llvm-compile-tests 48 | (is (compile {:op :module 49 | :name "module" 50 | :body [{:op :global 51 | :type {:type :array 52 | :size 3 53 | :etype :int} 54 | :name "SomeNumbers" 55 | :value [42 43 44]} 56 | {:op :fn 57 | :type {:type :fn 58 | :args [] 59 | :ret :int} 60 | :name "foo_func" 61 | :body {:op :const 62 | :value 42 63 | :type :int}}]})) 64 | (is 65 | (let [pyobj* :i8* 66 | pyfnc {:type :fn 67 | :args [:i8* :i8*] 68 | :ret :i8*} 69 | nil-const {:op :const 70 | :value nil 71 | :type :i8*} 72 | pyfnc-record {:type :struct 73 | :members [:i8* {:type :* 74 | :etype pyfnc} :int :i8*]} 75 | py-init-module {:op :fn 76 | :name "Py_InitModule4_64" 77 | :linkage :extern 78 | :type {:type :fn 79 | :args [:i8* {:type :* 80 | :etype pyfnc-record} 81 | :i8* :i8*] 82 | :ret :int} 83 | } 84 | from_long {:op :fn 85 | :type {:type :fn 86 | :ret pyobj* 87 | :args [:long]} 88 | :linkage :extern 89 | :name "PyInt_FromLong"} 90 | mod (compile {:op :module 91 | :name "module" 92 | :body (concat [from_long 93 | py-init-module] 94 | [{:op :fn 95 | :name "test_foo" 96 | :linkage :extern 97 | :type pyfnc 98 | :body {:op :call 99 | :fn "PyInt_FromLong" 100 | :args [{:op :const 101 | :value 42 102 | :type :long}]}} 103 | {:op :global 104 | :name "mbr_tbl" 105 | :type {:type :array 106 | :size 2 107 | :etype pyfnc-record} 108 | :value [["test_foo" 109 | {:global "test_foo"} 110 | 1 111 | "Test Fnc"] 112 | [nil nil 0 nil]]} 113 | 114 | {:op :fn 115 | :name "initfoo" 116 | :linkage :extern 117 | :type {:type :fn 118 | :args [] 119 | :ret :long} 120 | :body {:op :do 121 | :body [{:op :call 122 | :fn "Py_InitModule4_64" 123 | :args [{:op :const 124 | :value "foo" 125 | :type :i8*} 126 | {:op :bitcast 127 | :value 128 | {:op :get-global 129 | :name "mbr_tbl"} 130 | :type {:type :* 131 | :etype pyfnc-record}} 132 | nil-const 133 | nil-const]} 134 | {:op :const 135 | :value 42 136 | :type :long}]}}]) 137 | })] 138 | (link-object-file mod "foo.so" "x86-64" ["python-config" "--libs" "--ldflags"])))) -------------------------------------------------------------------------------- /src/clojure_py/constructors.clj: -------------------------------------------------------------------------------- 1 | (ns clojure-py.constructors 2 | (:refer-clojure :as j #_:exclude #_[defstruct]) 3 | (:require [clojure-py.llvmc :as llvmc])) 4 | 5 | (defn c-struct [name options] 6 | (let [members (partition 2 (:members options))] 7 | {:type :struct 8 | :name name 9 | :extends (:extends options) 10 | :members (mapv first members) 11 | :names (mapv second members)})) 12 | 13 | (defn make-accessor [type sym] 14 | (let [t (gensym)] 15 | `(defn ~(symbol (str "-" (name sym))) ~(vector t) 16 | (c-get ~t ~type ~sym)))) 17 | 18 | (defn d [x] 19 | (println x) 20 | x) 21 | 22 | (defmacro defc-struct [name & options] 23 | (let [opts (apply hash-map options)] 24 | (d `(do 25 | (def ~name (c-struct ~(clojure.core/name name) ~opts)) 26 | ~@(map (comp (partial make-accessor name) second) 27 | (partition 2 (:members opts))))))) 28 | 29 | 30 | #_(defn c-fn 31 | [nm args & body] 32 | (let 33 | (assert ret-type "Function must return a type (use -> type)") 34 | {:op :fn 35 | :type {:type :fn 36 | :args arg-types 37 | :ret ret-type} 38 | :name (name nm) 39 | :args (map second args) 40 | :body {:op :do 41 | :body body} 42 | :linkage (when (:extern (meta nm)) :external)})) 43 | 44 | #_(defmacro defc-fn 45 | [name args & body] 46 | `(def ~name (c-fn (with-meta (symbol ~(clojure.core/name name)) 47 | ~(meta name)) 48 | ~args 49 | ~@body))) 50 | 51 | 52 | (defn c-do [& body] 53 | {:pre [(not (nil? body))]} 54 | {:op :do 55 | :body body}) 56 | 57 | (defn c-if [test then else] 58 | {:op :if 59 | :test test 60 | :then then 61 | :else else}) 62 | 63 | (defn c-is [a b] 64 | {:op :is 65 | :a a 66 | :b b}) 67 | 68 | (defn c-set [ptr tp member val] 69 | {:op :set 70 | :ptr ptr 71 | :member member 72 | :type tp 73 | :value val}) 74 | 75 | (defn c-get [ptr tp member] 76 | {:op :get 77 | :ptr ptr 78 | :member member 79 | :type tp}) 80 | 81 | (defn c-aget [ptr idx] 82 | {:op :aget 83 | :ptr ptr 84 | :idx idx}) 85 | 86 | (defn c-idec [val] 87 | {:op :isub 88 | :a val 89 | :b {:op :const 90 | :type :int 91 | :value 1}}) 92 | 93 | (defn c-iadd 94 | ([a b] 95 | {:op :iadd 96 | :a a 97 | :b b}) 98 | ([a b & more] 99 | (reduce c-iadd 100 | (c-iadd a b) 101 | more))) 102 | 103 | (defn c-shl [a bits] 104 | {:op :shl 105 | :a a 106 | :bits bits}) 107 | 108 | (defn c-shr [a bits] 109 | {:op :shr 110 | :a a 111 | :bits bits}) 112 | 113 | (defn c-and [a b] 114 | {:op :and 115 | :a a 116 | :b b}) 117 | 118 | (defn c-iinc [val] 119 | {:op :iadd 120 | :a val 121 | :b {:op :const 122 | :type :int 123 | :value 1}}) 124 | 125 | (defn c-call [fn & args] 126 | {:op :call 127 | :fn fn 128 | :args args}) 129 | 130 | (defn const-int [value] 131 | {:op :const 132 | :type :int 133 | :value value}) 134 | 135 | (defmacro c-let [bindings & body] 136 | (reduce (fn [a [local binding]] 137 | (let [s (name (gensym "let_"))] 138 | `{:op :let 139 | :local ~s 140 | :binding ~binding 141 | :body (let [~local {:op :local 142 | :name ~s}] 143 | {:op :do 144 | :body ~a})})) 145 | `{:op :do 146 | :body ~(vec body)} 147 | (reverse (partition 2 bindings)))) 148 | 149 | #_(defmacro c-local [name] 150 | `{:op :local 151 | :name ~(clojure.core/name name)}) 152 | 153 | (defn c-malloc [tp] 154 | {:op :malloc 155 | :type tp}) 156 | 157 | (defn c-recur [& args] 158 | {:op :recur 159 | :args args}) 160 | 161 | (defn gen-name [s] 162 | (name (gensym s))) 163 | 164 | (defn c-pointer-t [tp] 165 | {:type :* 166 | :etype tp}) 167 | 168 | (defn c-nptr [tp] 169 | {:op :const 170 | :type tp 171 | :value nil}) 172 | 173 | (defn c-fn-t [args ret] 174 | {:pre [args ret]} 175 | {:type :fn 176 | :args args 177 | :ret ret}) 178 | 179 | (defmacro c-loc [name] 180 | {:op :local 181 | :name ~(clojure.core/name name)}) 182 | 183 | (defmacro c-fn [name tp args & body] 184 | {:pre [name tp args]} 185 | `{:op :fn 186 | :type ~tp 187 | :args ~(mapv clojure.core/name args) 188 | :name ~name 189 | :body (let ~(vec (mapcat (fn [x idx] [x {:op :arg 190 | :idx idx}]) 191 | args 192 | (range))) 193 | (c-do ~@body))}) 194 | 195 | (defmacro defextern [name args ret] 196 | `(do (register-global (.getName ~'*ns*) 197 | ~(clojure.core/name name) 198 | {:op :fn 199 | :linkage :external 200 | :type {:type :fn 201 | :args ~args 202 | :ret ~ret} 203 | :name ~(clojure.core/name name)}) 204 | (def ~name {:op :get-global :name ~name}))) 205 | 206 | (def registered-globals (atom {})) 207 | 208 | (defn register-global [ns nm gbl] 209 | (swap! registered-globals assoc-in [ns nm] gbl)) 210 | 211 | (defmacro defc-fn [name args & body] 212 | (let [args (partition 2 args) 213 | ret-fn (comp (partial = '->) first) 214 | ret-type (second (first (filter ret-fn args))) 215 | args (remove ret-fn args) 216 | args-map (zipmap (map second args) 217 | (range)) 218 | arg-types (mapv first args)] 219 | `(let [nsname# (.getName ~'*ns*) 220 | f# (c-fn (str nsname# "/" ~(clojure.core/name name)) 221 | (c-fn-t ~(mapv first args) ~ret-type) 222 | ~(mapv second args) 223 | ~@body)] 224 | (register-global nsname# ~(clojure.core/name name) f#) 225 | (defn ~name 226 | [& args#] 227 | {:op :call 228 | :fn {:op :get-global 229 | :name (:name f#)} 230 | :args (vec args#)})))) 231 | 232 | (defn c-free [local] 233 | {:op :free 234 | :pointer local}) 235 | 236 | (defn c-bitcast [ptr tp] 237 | {:op :bitcast 238 | :value ptr 239 | :type tp}) 240 | 241 | (defn c-new [tp & inits] 242 | {:op :new 243 | :type tp 244 | :members (vec inits)}) 245 | 246 | (defn c-gbl [name tp data] 247 | {:op :global 248 | :name name 249 | :type tp 250 | :value data}) 251 | 252 | (defmacro defc-gbl [name _ tp data] 253 | `(let [nsname# (.getName ~'*ns*) 254 | f# (c-gbl (str nsname# "/" ~(clojure.core/name name)) ~tp ~data)] 255 | (register-global nsname# ~(clojure.core/name name) f#) 256 | (def ~name {:op :get-global 257 | :name (:name f#)}))) 258 | 259 | 260 | (defn c-module [includes & body] 261 | {:op :module 262 | :name "main" 263 | :body (-> (reduce (fn [a x] 264 | (concat a 265 | (vals (@registered-globals x)))) 266 | [] 267 | includes) 268 | (concat body) 269 | vec)}) 270 | -------------------------------------------------------------------------------- /src/clojure_py/llvmc.clj: -------------------------------------------------------------------------------- 1 | (ns clojure-py.llvmc 2 | (:import (com.sun.jna Native Pointer Memory)) 3 | (:require [clojure.java.shell :as shell] 4 | [clojure.string :as string])) 5 | 6 | (def ^:dynamic *lib* 'LLVM-3.1) 7 | 8 | 9 | (defn get-function [s] 10 | `(com.sun.jna.Function/getFunction ~(name *lib*) ~(name s))) 11 | 12 | (defn debug [s] 13 | (println s) 14 | 15 | s) 16 | 17 | (def debug-mode false) 18 | 19 | (defmacro defnative 20 | [return-type function-symbol] 21 | `(let [func# ~(get-function function-symbol)] 22 | (defn ~(symbol (name function-symbol)) 23 | [& args#] 24 | (let [r# (.invoke func# ~return-type (to-array args#))] 25 | (when debug-mode 26 | (println "After " ~(name function-symbol)) 27 | (System/gc) 28 | (System/runFinalization) 29 | (Thread/sleep 500)) 30 | r#)))) 31 | 32 | (defn new-pointer [] 33 | (let [p (Memory. Pointer/SIZE)] 34 | (.clear p) 35 | p)) 36 | 37 | 38 | (defn to-pointers [& args] 39 | (let [arr (make-array Pointer (count args))] 40 | (loop [a args 41 | c 0] 42 | (if a 43 | (do (aset arr c (first a)) 44 | (recur (next a) (inc c))) 45 | arr)))) 46 | 47 | 48 | (def LLVMCCallConv 0) 49 | (def LLVMFastCallConv 8) 50 | (def LLVMColdCallConv 9) 51 | (def LLVMX86StdcallCallConv 64) 52 | (def LLVMX86FastcallCallConv 65) 53 | (defnative Integer LLVMSetFunctionCallConv) 54 | (defnative Integer LLVMFindFunction) 55 | 56 | (defnative Pointer LLVMAppendBasicBlock) 57 | (defnative Pointer LLVMCreateBuilder) 58 | 59 | (defnative Pointer LLVMGetParam) 60 | 61 | (defnative Integer LLVMLinkInJIT) 62 | '(defnative Integer LLVMInitializeNativeTarget) 63 | 64 | (defnative Pointer LLVMModuleCreateWithName) 65 | 66 | (defnative Pointer LLVMInt32Type) 67 | (defnative Pointer LLVMFunctionType) 68 | 69 | (defnative Pointer LLVMAddFunction) 70 | 71 | (defnative Integer LLVMPositionBuilderAtEnd) 72 | 73 | (defnative Boolean LLVMVerifyModule) 74 | 75 | (def LLVMAbortProcessAction 0) 76 | (def LLVMPrintMessageAction 1) 77 | (def LLVMReturnStatusAction 2) 78 | 79 | (defnative Pointer LLVMCreateModuleProviderForExistingModule) 80 | 81 | (defnative Integer LLVMDisposeMessage) 82 | (defnative Integer LLVMCreateJITCompiler) 83 | (defnative Integer LLVMCreateInterpreterForModule) 84 | (defnative Pointer LLVMCreatePassManager) 85 | (defnative Pointer LLVMGetExecutionEngineTargetData) 86 | (defnative Integer LLVMAddTargetData) 87 | (defnative Integer LLVMRunPassManager) 88 | (defnative Integer LLVMDumpModule) 89 | (defnative Integer LLVMDisposePassManager) 90 | (defnative Integer LLVMDisposeExecutionEngine) 91 | (defnative Integer LLVMBuildRet) 92 | 93 | (defnative Integer LLVMLinkInJIT) 94 | (defnative Integer LLVMLinkInInterpreter) 95 | (defnative Integer LLVMInitializeX86Target) 96 | (defnative Integer LLVMInitializeX86TargetInfo) 97 | (defnative Integer LLVMInitializeX86TargetMC) 98 | (defnative Pointer LLVMRunFunction) 99 | (defnative Boolean LLVMFindFunction) 100 | (defnative Pointer LLVMCreateGenericValueOfInt) 101 | (defnative Integer LLVMGenericValueToInt) 102 | (defnative Pointer LLVMBuildAdd) 103 | (defnative Pointer LLVMBuildSub) 104 | (defnative Pointer LLVMConstInt) 105 | (defnative Pointer LLVMBuildICmp) 106 | (defnative Pointer LLVMIntType) 107 | (defnative Pointer LLVMBuildCondBr) 108 | (defnative Pointer LLVMBuildPhi) 109 | (defnative Integer LLVMAddIncoming) 110 | (defnative Pointer LLVMTypeOf) 111 | (defnative Integer LLVMCountParamTypes) 112 | (defnative Integer LLVMGetTypeKind) 113 | (defnative Integer LLVMDisposeGenericValue) 114 | (defnative Integer LLVMDisposeBuilder) 115 | (defnative Pointer LLVMBuildBr) 116 | (defnative Pointer LLVMBuildCall) 117 | (defnative Pointer LLVMBuildAlloca) 118 | (defnative Pointer LLVMBuildFree) 119 | (defnative Pointer LLVMBuildLoad) 120 | (defnative Pointer LLVMBuildStore) 121 | 122 | (defnative Integer LLVMAddConstantPropagationPass) 123 | (defnative Integer LLVMAddInstructionCombiningPass) 124 | (defnative Integer LLVMAddPromoteMemoryToRegisterPass) 125 | (defnative Integer LLVMAddGVNPass) 126 | (defnative Integer LLVMAddCFGSimplificationPass) 127 | (defnative Pointer LLVMBuildArrayMalloc) 128 | (defnative Pointer LLVMBuildGEP) 129 | (defnative Pointer LLVMBuildBitCast) 130 | (defnative Pointer LLVMConstString) 131 | (defnative Pointer LLVMConstInt) 132 | (defnative Integer LLVMCountStructElementTypes) 133 | (defnative Pointer LLVMConstPointerCast) 134 | (defnative Pointer LLVMGetStructElementTypes) 135 | (defnative Integer LLVMGetTypeKind) 136 | (defnative Pointer LLVMConstPointerNull) 137 | (defnative Pointer LLVMInt64Type) 138 | (defnative Pointer LLVMStructType) 139 | (defnative Pointer LLVMArrayType) 140 | (defnative Pointer LLVMDumpValue) 141 | (defnative Integer LLVMGetArrayLength) 142 | (defnative Pointer LLVMGetElementType) 143 | (defnative Pointer LLVMConstArray) 144 | (defnative Pointer LLVMConstString) 145 | (defnative Pointer LLVMConstStruct) 146 | (defnative Pointer LLVMConstGEP) 147 | (defnative Pointer LLVMConstBitCast) 148 | (defnative Integer LLVMCountParams) 149 | (defnative Pointer LLVMAddGlobal) 150 | (defnative Integer LLVMSetInitializer) 151 | (defnative Integer LLVMWriteBitcodeToFile) 152 | (defnative Pointer LLVMGetNamedGlobal) 153 | (defnative Pointer LLVMGetNamedFunction) 154 | (defnative Pointer LLVMInt8Type) 155 | (defnative Pointer LLVMInt1Type) 156 | (defnative Pointer LLVMPointerType) 157 | (defnative Integer LLVMSetLinkage) 158 | (defnative Integer LLVMGetIntTypeWidth) 159 | (defnative Pointer LLVMBuildStructGEP) 160 | (defnative Pointer LLVMBuildAdd) 161 | (defnative Pointer LLVMBuildSub) 162 | (defnative Pointer LLVMBuildMalloc) 163 | 164 | (def ^:dynamic *module* (LLVMModuleCreateWithName "tmp")) 165 | (def ^:dynamic *fn*) 166 | (def ^:dynamic *locals*) 167 | (def ^:dynamic *builder*) 168 | (def ^:dynamic *block*) 169 | 170 | 171 | (def LLVMIntEQ 32) 172 | 173 | (defmacro defenum 174 | [nm defs] 175 | (list* 'do 176 | `(def ~nm {:idx ~(zipmap (range) 177 | (map (comp keyword name) defs)) 178 | :defs ~(zipmap (map (comp keyword name) defs) 179 | (range))}) 180 | (map-indexed (fn [idx d] 181 | `(def ~d ~idx)) 182 | defs))) 183 | 184 | (defenum LLVMTypeKind 185 | [LLVMVoidTypeKind 186 | LLVMHalfTypeKind 187 | LLVMFloatTypeKind 188 | LLVMDoubleTypeKind 189 | LLVMX86_FP80TypeKind 190 | LLVMFP128TypeKind 191 | LLVMPPC_FP128TypeKind 192 | LLVMLabelTypeKind 193 | LLVMIntegerTypeKind 194 | LLVMFunctionTypeKind 195 | LLVMStructTypeKind 196 | LLVMArrayTypeKind 197 | LLVMPointerTypeKind 198 | LLVMVectorTypeKind 199 | LLVMMetadataTypeKind 200 | LLVMX86_MMXTypeKind]) 201 | 202 | (defenum LLVMCodeGentFileType 203 | [LLVMAssemblyFile 204 | LLVMObjectFile]) 205 | 206 | (defenum LLVMRelocMode 207 | [LLVMRelocDefault 208 | LLVMRelocStatic 209 | LLVMRelocPIC 210 | LLVMRelocDynamicNoPIC]) 211 | 212 | (defenum LLVMCodeGenOptLevel 213 | [LLVMCodeGenLevelNone 214 | LLVMCodeGenLevelLess 215 | LLVMCodeGenLevelDefault 216 | LLVMCodeGenLevelAggressive]) 217 | 218 | (defenum LLVMCodeModel 219 | [LLVMCodeModelDefault 220 | LLVMCodeModelJITDefault 221 | LLVMCodeModelSmall 222 | LLVMCodeModelKernel 223 | LLVMCodeModelMedium 224 | LLVMCodeModelLarge]) 225 | 226 | 227 | (defenum LLVMLinkage 228 | [LLVMExternalLinkage, ; Externally visible function 229 | LLVMAvailableExternallyLinkage, 230 | LLVMLinkOnceAnyLinkage, ; Keep one copy of function when linking (inline) 231 | LLVMLinkOnceODRLinkage, ; Same, but only replaced by something equivalent. 232 | LLVMWeakAnyLinkage, ; Keep one copy of function when linking (weak) 233 | LLVMWeakODRLinkage, ; Same, but only replaced by something equivalent. 234 | LLVMAppendingLinkage, ; Special purpose, only applies to global arrays 235 | LLVMInternalLinkage, ; Rename collisions when linking (static functions) 236 | LLVMPrivateLinkage, ; Like Internal, but omit from symbol table 237 | LLVMDLLImportLinkage, ; Function to be imported from DLL 238 | LLVMDLLExportLinkage, ; Function to be accessible from DLL 239 | LLVMExternalWeakLinkage,; ExternalWeak linkage description 240 | LLVMGhostLinkage, ; Obsolete 241 | LLVMCommonLinkage, ; Tentative definitions 242 | LLVMLinkerPrivateLinkage, ; Like Private, but linker removes. 243 | LLVMLinkerPrivateWeakLinkage, ; Like LinkerPrivate, but is weak. 244 | LLVMLinkerPrivateWeakDefAutoLinkage]) ; Like LinkerPrivateWeak, but possibly hidden. 245 | 246 | 247 | (defn init-target [] 248 | (LLVMLinkInJIT) 249 | (LLVMLinkInInterpreter) 250 | (LLVMInitializeX86TargetInfo) 251 | (LLVMInitializeX86Target) 252 | (LLVMInitializeX86TargetMC)) 253 | 254 | (defn map-parr [fn coll] 255 | (into-array Pointer 256 | (map fn coll))) 257 | 258 | (def kw->linkage 259 | {:extern LLVMExternalLinkage}) 260 | 261 | (declare llvm-type 262 | ) 263 | 264 | (defmulti llvm-type-to-data (fn [tp] 265 | (get-in LLVMTypeKind [:idx (LLVMGetTypeKind tp)]))) 266 | 267 | (defmethod llvm-type-to-data :LLVMPointerTypeKind 268 | [tp] 269 | {:type :* 270 | :etype (llvm-type-to-data (LLVMGetElementType tp))}) 271 | 272 | (defmethod llvm-type-to-data :LLVMIntegerTypeKind 273 | [tp] 274 | {:type :int 275 | :width (LLVMGetIntTypeWidth tp)}) 276 | 277 | (defmethod llvm-type-to-data :LLVMArrayTypeKind 278 | [tp] 279 | {:type :array 280 | :etype (llvm-type-to-data (LLVMGetElementType tp)) 281 | :size (LLVMGetArrayLength tp)}) 282 | 283 | (defmethod llvm-type-to-data :LLVMStructTypeKind 284 | [tp] 285 | (let [cnt (LLVMCountStructElementTypes tp) 286 | arr (make-array Pointer cnt)] 287 | (LLVMGetStructElementTypes tp arr) 288 | {:type :struct 289 | :members (mapv llvm-type-to-data arr)})) 290 | 291 | (defmethod llvm-type-to-data :LLVMFunctionTypeKind 292 | [tp] 293 | :fn*) 294 | 295 | (defmulti encode-const (fn [tp v] 296 | (get-in LLVMTypeKind [:idx (LLVMGetTypeKind tp)]))) 297 | 298 | (defn const-string-array [s] 299 | (let [ar (into-array Pointer (map #(LLVMConstInt (llvm-type :i8) % false) 300 | (concat s [0]))) 301 | llvm-ar (LLVMConstArray (llvm-type :i8) 302 | ar 303 | (count ar)) 304 | idx (into-array Pointer 305 | [(LLVMConstInt (llvm-type :int) 0)]) 306 | gbl (LLVMAddGlobal *module* (llvm-type {:type :array 307 | :size (count ar) 308 | :etype :i8}) 309 | (name (gensym "str_"))) 310 | casted (LLVMConstBitCast gbl 311 | (llvm-type :i8*))] 312 | (LLVMSetInitializer gbl llvm-ar) 313 | 314 | casted 315 | )) 316 | 317 | (defmethod encode-const :LLVMPointerTypeKind 318 | [tp v] 319 | (cond 320 | (map? v) (LLVMGetNamedFunction *module* (:name v)) 321 | (string? v) (const-string-array v) #_(LLVMConstString v (count v) false) 322 | (instance? Pointer v) v 323 | (nil? v) (LLVMConstPointerNull tp) 324 | :else (assert false (str "Can't create pointer from " v)))) 325 | 326 | (defmethod encode-const :LLVMFunctionTypeKind 327 | [tp v] 328 | (assert (or (string? v) 329 | (nil? v))) 330 | (println "=========" tp (LLVMGetTypeKind tp)) 331 | (if (nil? v) 332 | (LLVMConstPointerNull tp) 333 | (let [fnc (LLVMGetNamedFunction *module* v)] 334 | (assert fnc (str "Couldn't find " v)) 335 | fnc))) 336 | 337 | (defmethod encode-const :LLVMIntegerTypeKind 338 | [tp v] 339 | (LLVMConstInt tp v true)) 340 | 341 | (defmethod encode-const :LLVMArrayTypeKind 342 | [tp v] 343 | (println (llvm-type-to-data tp)) 344 | (let [alen (LLVMGetArrayLength tp) 345 | atp (LLVMGetElementType tp) 346 | els (into-array Pointer 347 | (debug (map encode-const 348 | (repeat atp) 349 | v)))] 350 | (assert (= alen (count v)) (str "Wrong number of elements to constant array" alen " got " (count v))) 351 | (println "---------------------- " v) 352 | (LLVMConstArray atp 353 | els 354 | alen))) 355 | 356 | (defmethod encode-const :LLVMStructTypeKind 357 | [tp v] 358 | (let [cnt (LLVMCountStructElementTypes tp) 359 | arr (make-array Pointer cnt)] 360 | (assert (= cnt (count v))) 361 | (LLVMGetStructElementTypes tp arr) 362 | (LLVMConstStruct (into-array Pointer 363 | (debug (map encode-const arr v))) 364 | cnt 365 | false))) 366 | 367 | 368 | (println "Init LLVM") 369 | 370 | (defprotocol ILLVMTypeDesc 371 | (llvm-type [this])) 372 | 373 | 374 | (defmulti -llvm-type-kw identity) 375 | 376 | (defmethod -llvm-type-kw :default 377 | [kw] 378 | (if (= (last (name kw)) \*) 379 | (LLVMPointerType (->> (butlast (name kw)) 380 | (apply str) 381 | keyword 382 | llvm-type) 383 | 0) 384 | (assert false (str "Unknown type " kw)))) 385 | 386 | 387 | (defmethod -llvm-type-kw :int 388 | [kw] 389 | (LLVMIntType 32)) 390 | 391 | (defmethod -llvm-type-kw :long 392 | [kw] 393 | (LLVMIntType 64)) 394 | 395 | (defmethod -llvm-type-kw :i8 396 | [kw] 397 | (LLVMInt8Type)) 398 | 399 | (defmethod -llvm-type-kw :i1 400 | [kw] 401 | (LLVMInt1Type)) 402 | 403 | (defmethod -llvm-type-kw :bool 404 | [kw] 405 | (LLVMInt1Type)) 406 | 407 | (defmethod -llvm-type-kw :i8* 408 | [kw] 409 | (llvm-type 410 | {:type :* 411 | :etype :i8})) 412 | 413 | 414 | (defn flatten-struct [tp attr] 415 | (->> (take-while (complement nil?) 416 | (iterate :extends tp)) 417 | reverse 418 | (mapcat attr))) 419 | 420 | (defn seq-idx [col itm] 421 | {:post [%]} 422 | (-> (zipmap col 423 | (range)) 424 | (get itm))) 425 | 426 | (defmulti -llvm-type-assoc :type) 427 | (defmethod -llvm-type-assoc :struct 428 | [{:keys [members packed] :as struct}] 429 | (assert members) 430 | (let [ele (into-array Pointer 431 | (map llvm-type 432 | (flatten-struct struct :members))) 433 | packed (or packed false)] 434 | (LLVMStructType ele (count ele) packed))) 435 | 436 | 437 | (defmethod -llvm-type-assoc :* 438 | [{:keys [etype]}] 439 | (LLVMPointerType (llvm-type etype) 0)) 440 | 441 | (defmethod -llvm-type-assoc :array 442 | [{:keys [size etype]}] 443 | (assert (and size etype)) 444 | (LLVMArrayType (llvm-type etype) size)) 445 | 446 | (defmethod -llvm-type-assoc :fn 447 | [{:keys [ret args vararg?]}] 448 | (LLVMFunctionType (llvm-type ret) 449 | (into-array Pointer (map llvm-type args)) 450 | (count args) 451 | (or vararg? false))) 452 | 453 | (defmethod -llvm-type-assoc :fn* 454 | [mp] 455 | (LLVMPointerType (-llvm-type-assoc (assoc mp :type :fn)) 0)) 456 | 457 | 458 | 459 | (extend-protocol ILLVMTypeDesc 460 | clojure.lang.Keyword 461 | (llvm-type [this] 462 | (-llvm-type-kw this)) 463 | clojure.lang.Associative 464 | (llvm-type [this] 465 | (-llvm-type-assoc this))) 466 | 467 | (defn nstruct [name types & opts] 468 | (let [opts (apply hash-map opts)])) 469 | 470 | (def genname (comp name gensym)) 471 | 472 | 473 | 474 | (defn value-at [ptr] 475 | (.getPointer ptr 0)) 476 | 477 | 478 | 479 | (defmulti stub-global :op) 480 | 481 | (defmethod stub-global :global 482 | [{:keys [name type linkage]}] 483 | (assert (and name type)) 484 | (let [tp (llvm-type type) 485 | gbl (LLVMAddGlobal *module* tp name)] 486 | (when linkage 487 | (LLVMSetLinkage gbl (kw->linkage linkage))) 488 | gbl)) 489 | 490 | (defmethod stub-global :fn 491 | [{:keys [name type linkage]}] 492 | (println "stub" name) 493 | (let [tp (llvm-type type) 494 | gbl (LLVMAddFunction *module* name tp)] 495 | (when linkage 496 | (LLVMSetLinkage gbl (kw->linkage linkage))) 497 | gbl)) 498 | 499 | (defn op [o] 500 | (println (:op o)) 501 | (:op o)) 502 | 503 | (defmulti compile op) 504 | 505 | (defmethod compile :const 506 | [{:keys [value type]}] 507 | (let [tp (llvm-type type)] 508 | (encode-const tp value))) 509 | 510 | (defmethod compile :global 511 | [{:keys [type value name]}] 512 | {:pre [type value name]} 513 | (let [val (LLVMGetNamedGlobal *module* name)] 514 | (println "========== init ==========" name type) 515 | (LLVMSetInitializer val (encode-const (llvm-type type) value)))) 516 | 517 | (defmethod compile :aget 518 | [{:keys [idx ptr]}] 519 | (assert (and idx ptr)) 520 | (println "gep" (count idx) idx (map-parr compile idx)) 521 | (let [gep (LLVMBuildGEP *builder* 522 | (compile ptr) 523 | (map-parr compile idx) 524 | (count idx) 525 | (name (gensym "aget_")))] 526 | (println "g") 527 | (LLVMBuildLoad *builder* gep "load_"))) 528 | 529 | (defmethod compile :call 530 | [{:keys [fn args]}] 531 | (let [fnc (compile fn)] 532 | (assert fnc (str "Couldn't find function " fn)) 533 | (LLVMBuildCall *builder* 534 | fnc 535 | (map-parr compile args) 536 | (count args) 537 | (genname "call_")))) 538 | 539 | (defmethod compile :do 540 | [{:keys [body]}] 541 | {:pre [(seq? (seq body))]} 542 | (doseq [x (butlast body)] 543 | (compile x)) 544 | (compile (last body))) 545 | 546 | (defmethod compile :let 547 | [{:keys [local binding body]}] 548 | (clojure.core/binding [*locals* (assoc *locals* local (compile binding))] 549 | (compile body))) 550 | 551 | (defmethod compile :new 552 | [{:keys [type members]}] 553 | (let [malloc (LLVMBuildMalloc *builder* (llvm-type type) (name (gensym "new_")))] 554 | (doseq [idx (range (count members))] 555 | (let [gep (LLVMBuildStructGEP *builder* 556 | malloc 557 | idx 558 | (name (gensym "gep_")))] 559 | (LLVMBuildStore *builder* (compile (nth members idx)) gep))) 560 | malloc)) 561 | 562 | (defmethod compile :get 563 | [{:keys [ptr member type]}] 564 | (let [idx (seq-idx (flatten-struct type :names) member) 565 | _ (assert idx) 566 | cptr (compile {:op :bitcast 567 | :value ptr 568 | :type {:type :* 569 | :etype type}}) 570 | _ (println type idx) 571 | gep (LLVMBuildStructGEP *builder* 572 | cptr 573 | idx 574 | (name (gensym "get_")))] 575 | (LLVMBuildLoad *builder* gep "load_"))) 576 | 577 | (defmethod compile :set 578 | [{:keys [ptr member type value]}] 579 | (let [idx (seq-idx (flatten-struct type :names) member) 580 | ptr (compile {:op :bitcast 581 | :value ptr 582 | :type {:type :* 583 | :etype type}}) 584 | gep (LLVMBuildStructGEP *builder* ptr idx (name (gensym "set_")))] 585 | (LLVMBuildStore *builder* (compile value) gep) 586 | ptr)) 587 | 588 | 589 | (defmethod compile :isub 590 | [{:keys [a b]}] 591 | (LLVMBuildSub *builder* 592 | (compile a) 593 | (compile b) 594 | (name (gensym "isub_")))) 595 | 596 | (defmethod compile :if 597 | [{:keys [test then else]}] 598 | (let [thenblk (LLVMAppendBasicBlock *fn* (name (gensym "then_"))) 599 | elseblk (LLVMAppendBasicBlock *fn* (name (gensym "else_"))) 600 | endblk (LLVMAppendBasicBlock *fn* (name (gensym "end_"))) 601 | cmpval (compile test) 602 | _ (LLVMPositionBuilderAtEnd *builder* thenblk) 603 | thenval (binding [*block* thenblk] 604 | (compile then)) 605 | _ (LLVMPositionBuilderAtEnd *builder* elseblk) 606 | elseval (binding [*block* elseblk] 607 | (compile else)) 608 | _ (LLVMPositionBuilderAtEnd *builder* *block*) 609 | tmp (LLVMBuildAlloca *builder* (LLVMTypeOf thenval) "alloca_")] 610 | (LLVMBuildCondBr *builder* cmpval thenblk elseblk) 611 | (LLVMPositionBuilderAtEnd *builder* thenblk) 612 | (LLVMBuildStore *builder* thenval tmp) 613 | (LLVMBuildBr *builder* endblk) 614 | (LLVMPositionBuilderAtEnd *builder* elseblk) 615 | (LLVMBuildStore *builder* elseval tmp) 616 | (LLVMBuildBr *builder* endblk) 617 | (LLVMPositionBuilderAtEnd *builder* endblk) 618 | (LLVMBuildLoad *builder* tmp (name (gensym "ifval_"))))) 619 | 620 | (defmethod compile :iadd 621 | [{:keys [a b]}] 622 | (LLVMBuildAdd *builder* 623 | (compile a) 624 | (compile b) 625 | (name (gensym "iadd_")))) 626 | 627 | (defmethod compile :free 628 | [{:keys [pointer]}] 629 | (LLVMBuildFree *builder* (compile pointer)) 630 | (compile {:op :const :type :int :value 0})) 631 | 632 | 633 | (defmethod compile :get-global 634 | [{:keys [name]}] 635 | {:pre [name]} 636 | (println name) 637 | (or 638 | (LLVMGetNamedGlobal *module* name) 639 | (LLVMGetNamedFunction *module* name))) 640 | 641 | (defmethod compile :local 642 | [{:keys [name]}] 643 | {:post [%]} 644 | (println *locals*, name) 645 | (*locals* name)) 646 | 647 | (defmethod compile :bitcast 648 | [{:keys [type value]}] 649 | {:pre [type value]} 650 | (LLVMBuildBitCast *builder* 651 | (compile value) 652 | (llvm-type type) 653 | (name (gensym "bitcast_")))) 654 | 655 | (defmethod compile :is 656 | [{:keys [a b]}] 657 | (LLVMBuildICmp *builder* 658 | LLVMIntEQ 659 | (compile a) 660 | (compile b) 661 | (name (gensym "is_")))) 662 | 663 | (defmethod compile :arg 664 | [{:keys [idx]}] 665 | (LLVMGetParam *fn* idx)) 666 | 667 | (defmethod compile :fn 668 | [{:keys [type args name body]}] 669 | (when body 670 | (let [fnc (LLVMGetNamedFunction *module* name) 671 | pcnt (LLVMCountParams fnc) 672 | newargs (into {} (map (fn [s idx] 673 | [s (LLVMGetParam fnc idx )]) 674 | args 675 | (range pcnt)))] 676 | (LLVMSetFunctionCallConv fnc LLVMCCallConv) 677 | (binding [*fn* fnc 678 | *locals* newargs 679 | *block* (LLVMAppendBasicBlock fnc (genname "fblk_"))] 680 | (LLVMPositionBuilderAtEnd *builder* *block*) 681 | (LLVMBuildRet *builder* (compile body) (genname "return_")) 682 | fnc)))) 683 | 684 | (defmethod compile :module 685 | [{:keys [body name]}] 686 | (let [error (new-pointer) 687 | module (LLVMModuleCreateWithName name )] 688 | (binding [*module* module 689 | *builder* (LLVMCreateBuilder)] 690 | (doseq [x body] 691 | (stub-global x)) 692 | (doseq [x body] 693 | (println (:op x) "<______") 694 | (compile x)) 695 | (LLVMVerifyModule module LLVMAbortProcessAction error) 696 | (LLVMDumpModule module) 697 | (LLVMDisposeMessage (value-at error)) 698 | module))) 699 | 700 | (defmethod compile :default 701 | [ast] 702 | (assert false (str "Can't compile" ast))) 703 | 704 | (defn temp-file [prefix ext] 705 | (let [file (java.io.File/createTempFile prefix ext)] 706 | (.deleteOnExit file) 707 | (.getCanonicalPath file))) 708 | 709 | (defn dump-module-to-temp-file [module] 710 | (let [file (temp-file "mod_dump" ".bc")] 711 | (LLVMWriteBitcodeToFile module file) 712 | file)) 713 | 714 | 715 | (defn write-object-file [module march] 716 | (let [file (dump-module-to-temp-file module) 717 | ofile (temp-file "o_dump" ".o") 718 | cmds ["llc" "-filetype=obj" "-o" ofile file] 719 | cmds (if march (concat cmds ["--march" march]) cmds) 720 | {:keys [out err exit] :as mp} (apply shell/sh cmds)] 721 | (apply shell/sh ["llc" "-filetype=asm" "-o" "foo.s" file]) 722 | (println cmds) 723 | (assert (= exit 0) err) 724 | 725 | ofile)) 726 | 727 | (defn interpret-opt [op] 728 | (cond (vector? op) 729 | (let [res (apply shell/sh op)] 730 | (assert (= 0 (:exit res)) (:err res)) 731 | (string/split (string/trim (:out res)) #"[ \n]")) 732 | :else 733 | [op])) 734 | 735 | (defn link-object-file [module filename march & opts] 736 | (let [tmp (write-object-file module march) 737 | opts (mapcat interpret-opt opts) 738 | cmds (concat ["gcc" tmp] 739 | opts 740 | ["-o" filename "--shared"]) 741 | _ (println cmds) 742 | res (apply shell/sh cmds)] 743 | (assert (= 0 (:exit res)) res) 744 | (:out res))) 745 | 746 | (defn link-exe [obj out] 747 | (let [cmds (concat ["gcc" obj "-o" out "-lc"]) 748 | _ (println cmds) 749 | res (apply shell/sh cmds)] 750 | (assert (= 0 (:exit res)) res) 751 | (:out res))) 752 | 753 | 754 | 755 | (defn compile-as-exe [ast] 756 | (let [mod (compile ast) 757 | ofile (write-object-file mod "x86-64") 758 | exe-file (temp-file "exe_gen" "out") 759 | out (link-exe ofile exe-file)] 760 | exe-file)) 761 | 762 | (defn run-exe [file & args] 763 | (apply shell/sh file args)) 764 | 765 | 766 | ;;;;; TargetMachine Code ;;;; 767 | 768 | 769 | (defnative Pointer LLVMGetFirstTarget) 770 | (defnative Pointer LLVMGetNextTarget) 771 | (defnative String LLVMGetTargetName) 772 | (defnative String LLVMGetTargetDescription) 773 | (defnative Boolean LLVMTargetHasJIT) 774 | (defnative Boolean LLVMTargetHasTargetMachine) 775 | (defnative Boolean LLVMTargetHasAsmBackend) 776 | (defnative String LLVMGetTarget) 777 | (defnative Pointer LLVMCreateTargetMachine) 778 | (defnative Boolean LLVMTargetMachineEmitToFile) 779 | (defnative Pointer LLVMGetTargetMachineData) 780 | 781 | (defn target-info [t] 782 | {:target t 783 | :name (LLVMGetTargetName t) 784 | :desc (LLVMGetTargetDescription t) 785 | :jit? (LLVMTargetHasJIT t) 786 | :machine? (LLVMTargetHasTargetMachine t) 787 | :asm? (LLVMTargetHasAsmBackend t)}) 788 | 789 | (defn target-seq 790 | ([] 791 | (let [ft (LLVMGetFirstTarget)] 792 | (when ft 793 | (cons (target-info ft) 794 | (lazy-seq 795 | (target-seq ft)))))) 796 | ([t] 797 | (let [nt (LLVMGetNextTarget t)] 798 | (when nt 799 | (cons (target-info nt) 800 | (lazy-seq 801 | (target-seq nt))))))) 802 | 803 | (defn make-target-machine [module] 804 | (let [target (LLVMGetTarget module)] 805 | (println "--->" target) 806 | (LLVMCreateTargetMachine (:target 807 | (first (target-seq))) 808 | "x86_64-apple-darwin12.2.0" 809 | "i686" 810 | "" 811 | LLVMCodeGenLevelDefault 812 | LLVMRelocPIC 813 | LLVMCodeModelDefault))) 814 | 815 | (defn emit-to-file [module filename] 816 | (let [target (make-target-machine module) 817 | err (new-pointer) 818 | pass (LLVMCreatePassManager)] 819 | (LLVMAddTargetData (LLVMGetTargetMachineData target) pass) 820 | (LLVMRunPassManager pass module) 821 | 822 | (when (LLVMTargetMachineEmitToFile target module filename LLVMObjectFile err) 823 | (assert false (.getString (value-at err) 0))) 824 | (LLVMDisposeMessage (value-at err)) 825 | (LLVMDisposePassManager pass))) --------------------------------------------------------------------------------