├── README.md ├── project.clj ├── resources └── examples │ ├── bf │ ├── README.md │ ├── helloworld.bf │ └── mandelbrot.bf │ └── simple-lisp │ └── fib.lisp ├── src ├── examples │ ├── Mandelbrot.java │ ├── Vectors.java │ ├── bf.clj │ ├── jna_bench.clj │ ├── mandelbrot.clj │ ├── simple_lisp.clj │ └── vectors.clj └── mjolnir │ ├── config.clj │ ├── constructors_init.clj │ ├── core.clj │ ├── expressions.clj │ ├── gc.clj │ ├── gc │ └── boehm.clj │ ├── inference.clj │ ├── intrinsics.clj │ ├── llvm_builder.clj │ ├── llvmc.clj │ ├── ssa.clj │ ├── ssa_rules.clj │ ├── targets │ ├── darwin.clj │ ├── nvptx.clj │ ├── nvptx_cpus.clj │ ├── nvptx_intrinsics.clj │ ├── target.clj │ └── x86_cpus.clj │ ├── types.clj │ └── validation.clj └── test └── mjolnir └── simple_tests.clj /README.md: -------------------------------------------------------------------------------- 1 | # mjolnir 2 | 3 | Mjolnir is a Clojure library designed to simplify native code generation. It is useful for writing on-the-fly high performance code, writing programming languages, or simply for exploring new how code performs on different platforms. 4 | 5 | Internally, Mjolnir wraps the LLVM library. It then provides several layers of abstractions on top of LLVM. See the examples in the repository for indepth examples of the library at work. 6 | 7 | NOTE: the real work lately has been going on in the datomic branch. See recent additions to that branch for up-to-date examples. 8 | 9 | ## Layers 10 | 11 | Constructors - various Clojure functions that wrap expressions and can emulate let, defn, etc. To use these, use the following pattern 12 | 13 | (ns example 14 | (:require [mjolnir.constructors-init :as cinit]) 15 | (:alias c mjolnir.constructors)) 16 | 17 | The alias line performs some magic that allows code like the following from within any clojure file: 18 | 19 | (c/defn square [Int64 a -> Int64] 20 | (c/* a a)) 21 | 22 | 23 | Expressions - Constructors emit Mjolnir expressions. These live in `mjolnir.types` and `mjolnir.expressions`. These expressions are simply Clojure records that implement several common protocols. Once constructed, these expressions can be built via `mjolnir.expressions/build`. But most of the time this function will only be invoked against `mjolnir.expressions/Module` as this record contains alot of setup code that is neede for the other expressions to compile. 24 | 25 | LLVMC - Expressions invoke the many functions found in `mjolnir.llvmc`. This namespace simply wraps the many functions found in LLVM. The wrapping is done via JNA. 26 | 27 | LLVM-c - Internally, LLVM exposes the C++ api as a c library known as llvm-c. 28 | 29 | 30 | LLVM - And finally, at the bottom we have the llvm library 31 | 32 | ## defnf (Def Native Fn) 33 | 34 | Mjolnir supports a fairly basic, but powerful macro known as defnf. This macro acts much like Clojure's defn macro, but with C-like semantics: 35 | 36 | (defnf fib [Int64 x -> Int64] 37 | (if (< x 2) 38 | x 39 | (+ (fib (- x 1)) 40 | (fib (- x 2))))) 41 | 42 | The code inside the macro will be translated to mjolnir constructors (via pre-fixing c- to a symbol if possible). Then the entire function will be type infered. 43 | 44 | If a given variable is a struct, .- can be used to get a member: 45 | 46 | (defnf myfn [Point* pnt -> Int64] 47 | (.-x pnt)) 48 | 49 | In addition, pointer types support IFn, and when called, will create a cast operation: 50 | 51 | (myfn (Point* (malloc (sizeof Point)))) 52 | 53 | 54 | 55 | ## Supported Platforms 56 | 57 | At this time only OSX (64-bit) and NVidia PTX (on OSX) is supported. Adding new targets is easy, so if you want to add support for a platform, take a crack at it!. 58 | 59 | ## Usage 60 | 61 | FIXME 62 | 63 | ## License 64 | 65 | Copyright (c) 2012-2013 Timothy Baldridge 66 | 67 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 68 | 69 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 70 | 71 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 72 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject halgari/mjolnir "0.2.1" 2 | :description "Compiler Toolkit using LLVM" 3 | :url "http://github.com/halgari/mjolnir" 4 | :license {:name "MIT License"} 5 | :dependencies [[org.clojure/clojure "1.5.1"] 6 | [com.datomic/datomic-free "0.8.3826" ] 7 | [org.clojure/core.logic "0.8.3"] 8 | [net.java.dev.jna/jna "3.4.0"] 9 | [criterium "0.3.1"] 10 | #_[jcuda/jcuda "0.5.0"]] 11 | :test-paths ["test/"] 12 | :java-source-paths ["src/examples"] 13 | :jvm-opts ["-Djava.library.path=/usr/lib" 14 | "-Xmx4g"] 15 | :profiles {:ptx {:dependencies 16 | []}}) 17 | -------------------------------------------------------------------------------- /resources/examples/bf/README.md: -------------------------------------------------------------------------------- 1 | Sources for Files: 2 | 3 | Mandelbrot: http://bfj.googlecode.com/svn-history/r3/trunk/bfj/bf/mandelbrot.b" 4 | 5 | 6 | -------------------------------------------------------------------------------- /resources/examples/bf/helloworld.bf: -------------------------------------------------------------------------------- 1 | ++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>. 2 | -------------------------------------------------------------------------------- /resources/examples/bf/mandelbrot.bf: -------------------------------------------------------------------------------- 1 | A mandelbrot set fractal viewer in brainf*** written by Erik Bosman 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 | <<[->>>+<<<<<<<<<<<<[<<<<<<<<<]>>>[-]+>>>>>>[>>>>>>>>>]>[-]+<]]+>[-<[>>>>>>>>>]< 84 | <<<<<<<]>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>[-<<<+>>>]<<<[->>>+>>>>>>[>+>[-<->]<[->+ 85 | <]>>>>>>>>]<<<<<<<<+<[>[->>>>+<<[->>-<<<<<<<<<<<<<+>>>>>>>>>>[->>>+<<<]>]<[->>>- 86 | <<<<<<<<<<<<<+>>>>>>>>>>]<]>>[->>+<<<[->>>-<<<<<<<<<<<<<+>>>>>>>>>>]>]<[->>>+<<< 87 | ]<<<<<<<<<<<]>>>>>[-]>>[-<<<<<<<+>>>>>>>]<<<<<<<[->>>>>>>+<<+<<<<<]]>>>>[-<<<<+> 88 | >>>]<<<<[->>>>+>>>>>[>+>>[-<<->>]<<[->>+<<]>>>>>>>>]<<<<<<<<+<[>[->>>>+<<<[->>>- 89 | <<<<<<<<<<<<<+>>>>>>>>>>>[->>+<<]<]>[->>-<<<<<<<<<<<<<+>>>>>>>>>>>]<<]>[->>>+<<[ 90 | ->>-<<<<<<<<<<<<<+>>>>>>>>>>>]<]>[->>+<<]<<<<<<<<<<<<]]>>>>[-]<<<<]>>>>[-<<<<+>> 91 | >>]<<<<[->>>>+>[-]>>[-<<<<<<<+>>>>>>>]<<<<<<<[->>>>>>>+<<+<<<<<]>>>>>>>>>[>>>>>> 92 | >>>]<<<<<<<<<[>[->>>>+<<<[->>>-<<<<<<<<<<<<<+>>>>>>>>>>>[->>+<<]<]>[->>-<<<<<<<< 93 | <<<<<+>>>>>>>>>>>]<<]>[->>>+<<[->>-<<<<<<<<<<<<<+>>>>>>>>>>>]<]>[->>+<<]<<<<<<<< 94 | <<<<]]>>>>>>>>>[>>[-]>[-]>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>[-]>[-]>>>>>[>>>>>[-<<<<+ 95 | >>>>]<<<<[->>>>+<<<+<]>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>[>>>>>>[-<<<<<+>>>>> 96 | ]<<<<<[->>>>>+<<<+<<]>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>+++++++++++++++[[>>>> 97 | >>>>>]+>[-]>[-]>[-]>[-]>[-]>[-]>[-]>[-]>[-]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>-]+[>+>> 98 | >>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>[>->>>>[-<<<<+>>>>]<<<<[->>>>+<<<<<[->>[-<<+ 99 | >>]<<[->>+>>+<<<<]+>>>>>>>>>]<<<<<<<<[<<<<<<<<<]]>>>>>>>>>[>>>>>>>>>]<<<<<<<<<[> 100 | [->>>>>>>>>+<<<<<<<<<]<<<<<<<<<<]>[->>>>>>>>>+<<<<<<<<<]<+>>>>>>>>]<<<<<<<<<[>[- 101 | ]<->>>>[-<<<<+>[<->-<<<<<<+>>>>>>]<[->+<]>>>>]<<<[->>>+<<<]<+<<<<<<<<<]>>>>>>>>> 102 | [>+>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>[>->>>>>[-<<<<<+>>>>>]<<<<<[->>>>>+<<<< 103 | <<[->>>[-<<<+>>>]<<<[->>>+>+<<<<]+>>>>>>>>>]<<<<<<<<[<<<<<<<<<]]>>>>>>>>>[>>>>>> 104 | >>>]<<<<<<<<<[>>[->>>>>>>>>+<<<<<<<<<]<<<<<<<<<<<]>>[->>>>>>>>>+<<<<<<<<<]<<+>>> 105 | >>>>>]<<<<<<<<<[>[-]<->>>>[-<<<<+>[<->-<<<<<<+>>>>>>]<[->+<]>>>>]<<<[->>>+<<<]<+ 106 | <<<<<<<<<]>>>>>>>>>[>>>>[-<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<+>>>>>>>>>>>>>>>>> 107 | >>>>>>>>>>>>>>>>>>>]>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>+++++++++++++++[[>>>>>>>> 108 | >]<<<<<<<<<-<<<<<<<<<[<<<<<<<<<]>>>>>>>>>-]+>>>>>>>>>>>>>>>>>>>>>+<<<[<<<<<<<<<] 109 | >>>>>>>>>[>>>[-<<<->>>]+<<<[->>>->[-<<<<+>>>>]<<<<[->>>>+<<<<<<<<<<<<<[<<<<<<<<< 110 | ]>>>>[-]+>>>>>[>>>>>>>>>]>+<]]+>>>>[-<<<<->>>>]+<<<<[->>>>-<[-<<<+>>>]<<<[->>>+< 111 | <<<<<<<<<<<[<<<<<<<<<]>>>[-]+>>>>>>[>>>>>>>>>]>[-]+<]]+>[-<[>>>>>>>>>]<<<<<<<<]> 112 | >>>>>>>]<<<<<<<<<[<<<<<<<<<]>>->>[-<<<<+>>>>]<<<<[->>>>+<<[-]<<]>>]<<+>>>>[-<<<< 113 | ->>>>]+<<<<[->>>>-<<<<<<.>>]>>>>[-<<<<<<<.>>>>>>>]<<<[-]>[-]>[-]>[-]>[-]>[-]>>>[ 114 | >[-]>[-]>[-]>[-]>[-]>[-]>>>]<<<<<<<<<[<<<<<<<<<]>>>>>>>>>[>>>>>[-]>>>>]<<<<<<<<< 115 | [<<<<<<<<<]>+++++++++++[-[->>>>>>>>>+<<<<<<<<<]>>>>>>>>>]>>>>+>>>>>>>>>+<<<<<<<< 116 | <<<<<<[<<<<<<<<<]>>>>>>>[-<<<<<<<+>>>>>>>]<<<<<<<[->>>>>>>+[-]>>[>>>>>>>>>]<<<<< 117 | <<<<[>>>>>>>[-<<<<<<+>>>>>>]<<<<<<[->>>>>>+<<<<<<<[<<<<<<<<<]>>>>>>>[-]+>>>]<<<< 118 | <<<<<<]]>>>>>>>[-<<<<<<<+>>>>>>>]<<<<<<<[->>>>>>>+>>[>+>>>>[-<<<<->>>>]<<<<[->>> 119 | >+<<<<]>>>>>>>>]<<+<<<<<<<[>>>>>[->>+<<]<<<<<<<<<<<<<<]>>>>>>>>>[>>>>>>>>>]<<<<< 120 | <<<<[>[-]<->>>>>>>[-<<<<<<<+>[<->-<<<+>>>]<[->+<]>>>>>>>]<<<<<<[->>>>>>+<<<<<<]< 121 | +<<<<<<<<<]>>>>>>>-<<<<[-]+<<<]+>>>>>>>[-<<<<<<<->>>>>>>]+<<<<<<<[->>>>>>>->>[>> 122 | >>>[->>+<<]>>>>]<<<<<<<<<[>[-]<->>>>>>>[-<<<<<<<+>[<->-<<<+>>>]<[->+<]>>>>>>>]<< 123 | <<<<[->>>>>>+<<<<<<]<+<<<<<<<<<]>+++++[-[->>>>>>>>>+<<<<<<<<<]>>>>>>>>>]>>>>+<<< 124 | <<[<<<<<<<<<]>>>>>>>>>[>>>>>[-<<<<<->>>>>]+<<<<<[->>>>>->>[-<<<<<<<+>>>>>>>]<<<< 125 | <<<[->>>>>>>+<<<<<<<<<<<<<<<<[<<<<<<<<<]>>>>[-]+>>>>>[>>>>>>>>>]>+<]]+>>>>>>>[-< 126 | <<<<<<->>>>>>>]+<<<<<<<[->>>>>>>-<<[-<<<<<+>>>>>]<<<<<[->>>>>+<<<<<<<<<<<<<<[<<< 127 | <<<<<<]>>>[-]+>>>>>>[>>>>>>>>>]>[-]+<]]+>[-<[>>>>>>>>>]<<<<<<<<]>>>>>>>>]<<<<<<< 128 | <<[<<<<<<<<<]>>>>[-]<<<+++++[-[->>>>>>>>>+<<<<<<<<<]>>>>>>>>>]>>>>-<<<<<[<<<<<<< 129 | <<]]>>>]<<<<.>>>>>>>>>>[>>>>>>[-]>>>]<<<<<<<<<[<<<<<<<<<]>++++++++++[-[->>>>>>>> 130 | >+<<<<<<<<<]>>>>>>>>>]>>>>>+>>>>>>>>>+<<<<<<<<<<<<<<<[<<<<<<<<<]>>>>>>>>[-<<<<<< 131 | <<+>>>>>>>>]<<<<<<<<[->>>>>>>>+[-]>[>>>>>>>>>]<<<<<<<<<[>>>>>>>>[-<<<<<<<+>>>>>> 132 | >]<<<<<<<[->>>>>>>+<<<<<<<<[<<<<<<<<<]>>>>>>>>[-]+>>]<<<<<<<<<<]]>>>>>>>>[-<<<<< 133 | <<<+>>>>>>>>]<<<<<<<<[->>>>>>>>+>[>+>>>>>[-<<<<<->>>>>]<<<<<[->>>>>+<<<<<]>>>>>> 134 | >>]<+<<<<<<<<[>>>>>>[->>+<<]<<<<<<<<<<<<<<<]>>>>>>>>>[>>>>>>>>>]<<<<<<<<<[>[-]<- 135 | >>>>>>>>[-<<<<<<<<+>[<->-<<+>>]<[->+<]>>>>>>>>]<<<<<<<[->>>>>>>+<<<<<<<]<+<<<<<< 136 | <<<]>>>>>>>>-<<<<<[-]+<<<]+>>>>>>>>[-<<<<<<<<->>>>>>>>]+<<<<<<<<[->>>>>>>>->[>>> 137 | >>>[->>+<<]>>>]<<<<<<<<<[>[-]<->>>>>>>>[-<<<<<<<<+>[<->-<<+>>]<[->+<]>>>>>>>>]<< 138 | <<<<<[->>>>>>>+<<<<<<<]<+<<<<<<<<<]>+++++[-[->>>>>>>>>+<<<<<<<<<]>>>>>>>>>]>>>>> 139 | +>>>>>>>>>>>>>>>>>>>>>>>>>>>+<<<<<<[<<<<<<<<<]>>>>>>>>>[>>>>>>[-<<<<<<->>>>>>]+< 140 | <<<<<[->>>>>>->>[-<<<<<<<<+>>>>>>>>]<<<<<<<<[->>>>>>>>+<<<<<<<<<<<<<<<<<[<<<<<<< 141 | <<]>>>>[-]+>>>>>[>>>>>>>>>]>+<]]+>>>>>>>>[-<<<<<<<<->>>>>>>>]+<<<<<<<<[->>>>>>>> 142 | -<<[-<<<<<<+>>>>>>]<<<<<<[->>>>>>+<<<<<<<<<<<<<<<[<<<<<<<<<]>>>[-]+>>>>>>[>>>>>> 143 | >>>]>[-]+<]]+>[-<[>>>>>>>>>]<<<<<<<<]>>>>>>>>]<<<<<<<<<[<<<<<<<<<]>>>>[-]<<<++++ 144 | +[-[->>>>>>>>>+<<<<<<<<<]>>>>>>>>>]>>>>>->>>>>>>>>>>>>>>>>>>>>>>>>>>-<<<<<<[<<<< 145 | <<<<<]]>>>] 146 | -------------------------------------------------------------------------------- /resources/examples/simple-lisp/fib.lisp: -------------------------------------------------------------------------------- 1 | (defn fib [a] 2 | (if (= a 0) 3 | a 4 | (if (= a 1) 5 | a 6 | (+ (fib (+ a -1)) 7 | (fib (+ a -2)))))) 8 | 9 | (defn -run [] 10 | (fib 10)) 11 | -------------------------------------------------------------------------------- /src/examples/Mandelbrot.java: -------------------------------------------------------------------------------- 1 | package examples; 2 | 3 | public class Mandelbrot 4 | { 5 | public static float calcIteration(float xpx, float ypx, float max, float width, float height) 6 | { 7 | // Scale x & y to within (-2.5, -1) to (1, 1) 8 | float x0 = ((xpx / width) * (float)3.5) - (float)2.5; 9 | float y0 = ((ypx / height) * (float)2) - (float)1; 10 | 11 | float x = 0; 12 | float y = 0; 13 | 14 | float iteration = 0; 15 | 16 | while ((x * x) + (y * y) < (2 * 2) && iteration < max) 17 | { 18 | float xtemp = (x * x) - (y * y) + x0; 19 | y = (2 * x * y) + y0; 20 | x = xtemp; 21 | iteration += 1; 22 | } 23 | return iteration; 24 | } 25 | 26 | public static float[] calcMandelbrot(float[] arr, float width, float max) 27 | { 28 | float height = (float)arr.length / width; 29 | for (float y = 0; y < height; y ++) { 30 | for (float x = 0; x < width; x++) { 31 | int idx = (int)((y * width) + x); 32 | arr[idx] = calcIteration(x, y, max, width, height) / max; 33 | } 34 | } 35 | return arr; 36 | } 37 | 38 | } 39 | -------------------------------------------------------------------------------- /src/examples/Vectors.java: -------------------------------------------------------------------------------- 1 | package examples; 2 | 3 | public class Vectors 4 | { 5 | public static double square(double x) 6 | { 7 | return x * x; 8 | } 9 | 10 | public static double[] createBuffer(long size) 11 | { 12 | return new double[(int)size]; 13 | } 14 | 15 | public static double length(double[] v, long size) 16 | { 17 | double sum = 0; 18 | for (long x = 0; x < size; x++) 19 | { 20 | sum += square(v[(int)x]); 21 | } 22 | return Math.sqrt(sum); 23 | } 24 | 25 | public static double[] normalize(double[] v, long size) 26 | { 27 | double len = length(v, size); 28 | for (long x = 0; x < size; x++) 29 | { 30 | v[(int)x] /= len; 31 | } 32 | return v; 33 | } 34 | 35 | } 36 | -------------------------------------------------------------------------------- /src/examples/bf.clj: -------------------------------------------------------------------------------- 1 | (ns examples.bf 2 | (:require [mjolnir.expressions :as exp] 3 | [mjolnir.inference :refer [infer-all]] 4 | [mjolnir.validation :refer [validate]] 5 | [mjolnir.constructors-init :as const] 6 | [mjolnir.types :refer [Int64 ->PointerType valid? ->ArrayType]] 7 | [mjolnir.llvmc :as l] 8 | [mjolnir.config :as config] 9 | [mjolnir.targets.target :refer [emit-to-file]] 10 | [mjolnir.core :as core]) 11 | (:alias c mjolnir.constructors)) 12 | 13 | 14 | (def cells (c/local "cells")) 15 | 16 | 17 | (def Cells (->PointerType Int64)) 18 | (def RunCode-t (c/fn-t [] Int64)) 19 | 20 | 21 | (c/defn ^:extern ^:exact getchar [-> Int64]) 22 | (c/defn ^:extern ^:exact putchar [Int64 chr -> Int64]) 23 | 24 | (defmulti compile-bf (fn [ip code] (first code))) 25 | 26 | 27 | (defn compile-block [ip code] 28 | (loop [ip ip 29 | code code] 30 | (if (= \] (first code)) 31 | {:code (next code) 32 | :ip ip} 33 | (let [c (compile-bf ip code)] 34 | (recur (:ip c) 35 | (:code c)))))) 36 | 37 | (defmethod compile-bf :default 38 | [ip code] 39 | {:ip ip 40 | :code (next code)}) 41 | 42 | (defmethod compile-bf \> 43 | [ip code] 44 | {:ip (c/+ ip 1) 45 | :code (next code)}) 46 | 47 | (defmethod compile-bf \< 48 | [ip code] 49 | {:ip (c/- ip 1) 50 | :code (next code)}) 51 | 52 | (defmethod compile-bf \+ 53 | [in-ip code] 54 | {:ip (c/let [ip in-ip] 55 | (c/aset cells 56 | ip 57 | (c/+ (c/aget cells ip) 1)) 58 | ip) 59 | :code (next code)}) 60 | 61 | (defmethod compile-bf \- 62 | [in-ip code] 63 | {:ip (c/let [ip in-ip] 64 | (c/aset cells 65 | ip 66 | (c/- (c/aget cells ip) 1)) 67 | ip) 68 | :code (next code)}) 69 | 70 | (defmethod compile-bf \. 71 | [in-ip code] 72 | {:ip (c/let [ip in-ip] 73 | (putchar (c/aget cells ip)) 74 | ip) 75 | :code (next code)}) 76 | 77 | 78 | (defmethod compile-bf \, 79 | [in-ip code] 80 | {:ip (c/let [ip in-ip] 81 | (c/aset cells ip (getchar)) 82 | ip) 83 | :code (next code)}) 84 | 85 | 86 | (comment 87 | ;; loop logic 88 | 89 | (loop [ip in-ip] 90 | (if (aget = 0) 91 | ip)) 92 | 93 | ) 94 | 95 | 96 | (defmethod compile-bf \[ 97 | [ip code] 98 | (let [ip_name (name (gensym "ip_")) 99 | {ret-code :code ret-ip :ip} 100 | (compile-block (exp/->Local ip_name) (next code))] 101 | 102 | {:ip (exp/->Loop [[ip_name ip]] 103 | (c/if (c/= (c/aget cells (exp/->Local ip_name)) 0) 104 | (exp/->Local ip_name) 105 | (c/recur ret-ip))) 106 | :code ret-code})) 107 | 108 | (defn -main [program & opts] 109 | (println opts) 110 | (let [options (apply hash-map (map read-string opts)) 111 | program-code (slurp program) 112 | _ (println "Building Expressions") 113 | 114 | cfn (const/c-fn "main" RunCode-t [] 115 | nil 116 | (c/using [cells (c/bitcast (c/malloc (->ArrayType Int64 30000)) Cells)] 117 | (c/dotimes [x 30000] 118 | (c/aset cells x 0)) 119 | (loop [ip 0 120 | code program-code] 121 | (let [{ip :ip code :code} (compile-bf ip code)] 122 | 123 | (if code 124 | (recur ip code) 125 | ip)))))] 126 | 127 | (try 128 | (binding [config/*target* (config/default-target) 129 | config/*int-type* Int64] 130 | (let [_ (println "Compiling") 131 | module (c/module ['examples.bf] 132 | cfn) 133 | conn (core/to-db module) 134 | built (core/to-llvm-module conn) 135 | 136 | optimized built 137 | _ (println "Writing Object File") 138 | compiled (time (emit-to-file config/*target* 139 | optimized 140 | options))])) 141 | (println "Finished") 142 | (finally 143 | (shutdown-agents))) 144 | 0)) 145 | 146 | 147 | 148 | 149 | 150 | -------------------------------------------------------------------------------- /src/examples/jna_bench.clj: -------------------------------------------------------------------------------- 1 | (ns examples.jna-bench 2 | (:require [criterium.core :as crit]) 3 | (:import [com.sun.jna Native Pointer Memory Function Platform])) 4 | 5 | (set! *warn-on-reflection* true) 6 | 7 | (defn cos-invoke ^Function [] 8 | (com.sun.jna.Function/getFunction Platform/C_LIBRARY_NAME "cos")) 9 | 10 | 11 | (defn -main [] 12 | (let [f (cos-invoke)] 13 | (crit/quick-bench 14 | (.invoke f Double (object-array [0.5]))))) 15 | 16 | -------------------------------------------------------------------------------- /src/examples/mandelbrot.clj: -------------------------------------------------------------------------------- 1 | (ns examples.mandelbrot 2 | (:require [criterium.core :as crit]) 3 | (:require [mjolnir.constructors-init :refer [defnf]] 4 | [mjolnir.types :as types :refer [I8* Int64 Float32 Float32* Float64x4 Float64x4* VoidT]] 5 | [mjolnir.expressions :refer [build optimize dump ->ConstVector ->Do ->FPToSI ->SIToFP]] 6 | [mjolnir.config :as config] 7 | [mjolnir.targets.target :refer [emit-to-file as-dll]] 8 | [mjolnir.intrinsics :as intr] 9 | #_[mjolnir.targets.nvptx-intrinsics :refer [TID_X NTID_X CTAID_X TID_Y NTID_Y CTAID_Y]] 10 | #_[mjolnir.targets.nvptx :as nvptx] 11 | [mjolnir.core :refer [build-module]]) 12 | (:alias c mjolnir.constructors) 13 | (:import [java.awt Color Image Dimension] 14 | [javax.swing JPanel JFrame SwingUtilities] 15 | [java.awt.image BufferedImage] 16 | [examples Mandelbrot] 17 | [com.sun.jna Native Pointer Memory] 18 | )) 19 | 20 | 21 | (defn display-image [^floats d ^long width] 22 | (let [img (BufferedImage. width (/ (count d) width) BufferedImage/TYPE_INT_ARGB) 23 | height (long (/ (count d) width))] 24 | (println "Converting....") 25 | (dotimes [x width] 26 | (dotimes [y height] 27 | (let [idx (+ (* y width) x) 28 | val (unchecked-float (aget d idx)) 29 | c (if (= val 1.0) 30 | (Color/getHSBColor val 1 0) 31 | (Color/getHSBColor (+ 0.5 val) 1 0.5))] 32 | (.setRGB img x y (.getRGB c))))) 33 | (doto 34 | (JFrame.) 35 | (.setContentPane 36 | (doto 37 | (proxy [JPanel] 38 | [] 39 | (paintComponent [g] 40 | #_(proxy-super paintComponent g) 41 | (let [width (.getWidth this) 42 | height (* width 43 | (/ (.getHeight img nil) 44 | (.getWidth img nil))) 45 | scaled (.getScaledInstance img width height Image/SCALE_SMOOTH)] 46 | (.drawImage g scaled 0 0 this)))) 47 | (.setPreferredSize (Dimension. 1024 1024)))) 48 | (.setSize 1024 512) 49 | (.show)))) 50 | 51 | ;; Mjolnir Method (no SSE) 52 | 53 | (defnf square [Float32 x -> Float32] 54 | (* x x)) 55 | 56 | 57 | 58 | (defnf calc-iteration [Float32 xpx Float32 ypx Float32 max Float32 width Float32 height -> Float32] 59 | (let [x0 (- (* (/ xpx width) 3.5) 2.5) 60 | y0 (- (/ (/ ypx height) 2.0) 1.0)] 61 | (loop [iteration 0.0 62 | x 0.0 63 | y 0.0] 64 | (if (and (< (+ (square x) 65 | (square y)) 66 | (square 2.0)) 67 | (< iteration max)) 68 | (recur (+ iteration 1.0) 69 | (+ (- (square x) 70 | (square y)) 71 | x0) 72 | (+ (* 2.0 x y) 73 | y0)) 74 | iteration)))) 75 | 76 | (defnf ^:extern calc-mandelbrot [Float32* arr Float32 width Float32 height Float32 max -> Float32*] 77 | (for [y [0.0 height 1.0]] 78 | (for [x [0.0 width 1.0]] 79 | (let [idx (cast Int64 (+ (* y width) x))] 80 | (aset arr idx (/ (calc-iteration x y max width height) max))))) 81 | arr) 82 | 83 | #_(defnf ^:extern calc-mandelbrot-ptx [Float32* arr 84 | Float32 width 85 | Float32 height 86 | Float32 max 87 | -> VoidT] 88 | (let [xpx (cast Float32 (+ (* (CTAID_X) (NTID_X)) 89 | (TID_X))) 90 | ypx (cast Float32 (+ (* (CTAID_Y) (NTID_Y)) 91 | (TID_Y))) 92 | idx (cast Int64 (+ (* ypx width) xpx)) 93 | c (calc-iteration xpx ypx max width height)] 94 | (aset arr idx (/ c max)))) 95 | 96 | (defn memory-to-array [^Memory m size] 97 | (let [arr (float-array size)] 98 | (dotimes [x size] 99 | (aset-float arr 100 | x 101 | (.getFloat m (* x 4)))) 102 | arr)) 103 | 104 | (def WIDTH 1024.0) 105 | (def HEIGHT 512.0) 106 | (def SIZE (* WIDTH HEIGHT)) 107 | 108 | (defmulti run-command vector) 109 | 110 | (defmethod run-command [:run :all] 111 | [_ _] 112 | (run-command :run :java)) 113 | 114 | (defmethod run-command [:run :java] 115 | [_ _] 116 | (let [img (time (Mandelbrot/calcMandelbrot (float-array SIZE) 117 | WIDTH 118 | 1000))] 119 | (display-image img WIDTH))) 120 | 121 | 122 | #_(defmethod run-command [:run :ptx] 123 | [_ _] 124 | (nvptx/init-target identity) 125 | (binding 126 | [config/*target* (nvptx/make-default-target) 127 | config/*float-type* Float32 128 | config/*int-type* Int64] 129 | (let [module (c/module ['examples.mandelbrot/square 130 | 'examples.mandelbrot/calc-iteration 131 | 'examples.mandelbrot/calc-mandelbrot-ptx 132 | 'mjolnir.targets.nvptx-intrinsics]) 133 | built (optimize (build module))] 134 | (emit-to-file 135 | config/*target* 136 | built 137 | {:filename "mandelbrot2.ptx" 138 | :obj-type :asm}) 139 | (let [dll (as-dll (nvptx/make-default-target) built {}) 140 | f ((get dll calc-mandelbrot-ptx) [(/ WIDTH 16) (/ HEIGHT 32)] [16 32]) 141 | ptr (nvptx/device-alloc (* SIZE 4))] 142 | (time (f ptr WIDTH HEIGHT 1000.0)) 143 | (try 144 | (display-image (nvptx/to-float-array ptr SIZE) WIDTH) 145 | (finally 146 | (nvptx/free ptr))) 147 | (println "loaded"))))) 148 | 149 | (defmethod run-command [:run :mjolnir] 150 | [_ _] 151 | (binding [config/*target* (config/default-target) 152 | config/*float-type* Float32 153 | config/*int-type* Int64] 154 | (let [module (c/module ['examples.mandelbrot/square 155 | 'examples.mandelbrot/calc-iteration 156 | 'examples.mandelbrot/calc-mandelbrot]) 157 | built (optimize (build module)) 158 | _ (dump built) 159 | dll (as-dll 160 | config/*target* 161 | built 162 | {:verbose true 163 | :obj-type :asm}) 164 | mbf (get dll calc-mandelbrot) 165 | buf (Memory. (* SIZE 8))] 166 | (assert (and mbf dll) "Compilation error") 167 | (println "Running...") 168 | (time (mbf buf (float WIDTH) (float HEIGHT) (float 1000.0))) 169 | #_(println (distinct (memory-to-array buf SIZE))) 170 | (display-image (memory-to-array buf SIZE) WIDTH)))) 171 | 172 | #_(defmethod run-command [:benchmark :ptx] 173 | [_ _] 174 | (nvptx/init-target identity) 175 | (binding 176 | [config/*target* (nvptx/make-default-target) 177 | config/*float-type* Float32 178 | config/*int-type* Int64] 179 | (let [module (c/module ['examples.mandelbrot/square 180 | 'examples.mandelbrot/calc-iteration 181 | 'examples.mandelbrot/calc-mandelbrot-ptx 182 | 'mjolnir.targets.nvptx-intrinsics]) 183 | built (optimize (build module))] 184 | (emit-to-file 185 | config/*target* 186 | built 187 | {:filename "mandelbrot2.ptx" 188 | :obj-type :asm}) 189 | (let [dll (as-dll (nvptx/make-default-target) built {}) 190 | f ((get dll calc-mandelbrot-ptx) #_[(/ WIDTH 128) (/ HEIGHT 64)] #_[128 64] 191 | [128 2] [8 256]) 192 | ptr (nvptx/device-alloc (* SIZE 8))] 193 | (crit/quick-bench (f ptr WIDTH HEIGHT 1000.0)) 194 | (nvptx/free ptr))))) 195 | 196 | 197 | (defmethod run-command [:benchmark :mjolnir] 198 | [_ _] 199 | (binding [config/*target* (config/default-target) 200 | config/*float-type* Float32 201 | config/*int-type* Int64] 202 | (let [module (c/module ['examples.mandelbrot/square 203 | 'examples.mandelbrot/calc-iteration 204 | 'examples.mandelbrot/calc-mandelbrot]) 205 | built (build-module module) 206 | _ (dump built) 207 | dll (as-dll (config/default-target) 208 | built 209 | {:verbose true}) 210 | mbf (get dll calc-mandelbrot) 211 | buf (Memory. (* SIZE 8))] 212 | (assert (and mbf dll) "Compilation error") 213 | (println "Running...") 214 | (crit/bench 215 | (mbf buf WIDTH HEIGHT 1000.0))))) 216 | 217 | (defmethod run-command [:benchmark :java] 218 | [_ _] 219 | (crit/bench 220 | (Mandelbrot/calcMandelbrot (float-array SIZE) 221 | WIDTH 222 | 1000))) 223 | 224 | (defn -main [& opts] 225 | (apply run-command (map read-string opts))) 226 | 227 | 228 | 229 | -------------------------------------------------------------------------------- /src/examples/simple_lisp.clj: -------------------------------------------------------------------------------- 1 | (ns examples.simple-lisp 2 | (:gen-class) 3 | (:require 4 | [mjolnir.config :as config] 5 | [mjolnir.core :refer [to-db to-llvm-module]] 6 | [mjolnir.types :refer :all] 7 | [mjolnir.expressions :refer :all] 8 | [mjolnir.constructors-init :as costructors-init] 9 | [clojure.pprint :refer [pprint]] 10 | [mjolnir.targets.target :refer [emit-to-file]]) 11 | (:alias c mjolnir.constructors)) 12 | 13 | ;; This is an example of an extremely simple lisp-like compiler built 14 | ;; using Mjolnir. This is not feature complete, and most likely will 15 | ;; never be, but it serves as an example of how more complex systems 16 | ;; could be developed in Mjolnir. 17 | 18 | ;; Type System 19 | ;; Our type system is simply a set of structs. We'll have a typeid in 20 | ;; the parent object, and each child struct will have one or more 21 | ;; value members 22 | 23 | (c/defstruct WObject 24 | :members [Int64 type]) 25 | 26 | (c/defstruct WInt64 27 | :extends WObject 28 | :members [Int64 int64-value]) 29 | 30 | (c/defstruct WString 31 | :extends WObject 32 | :members [Int8* str-value]) 33 | 34 | (c/defstruct WFn 35 | :extends WObject 36 | :members [Int8* fn-value]) 37 | 38 | 39 | 40 | ;; Defs from external libs. Mjolnir doesn't support varargs yet, so we 41 | ;; just have one version of print-Int64 42 | (c/defn ^{:exact "GC_malloc"} ^:extern GC_malloc [Int64 size -> Int8*]) 43 | (c/defn ^{:exact "GC_init"} ^:extern GC_init [-> Int8*]) 44 | (c/defn ^{:exact "printf"} ^:extern print-Int64 [Int8* format Int64 val -> Int64 ]) 45 | 46 | 47 | ;; Simple constructor fn for allocating a struct from GC memory 48 | (defn tmalloc [tp] 49 | ((->PointerType tp) 50 | (GC_malloc (->SizeOf tp)))) 51 | 52 | ;; Define some helper pointer types 53 | (def WObject* (->PointerType WObject)) 54 | (def WObject** (->PointerType WObject*)) 55 | (def WObject*** (->PointerType WObject**)) 56 | (def WInt64* (->PointerType WInt64)) 57 | (def WString* (->PointerType WString)) 58 | (def WFn* (->PointerType WFn)) 59 | 60 | ;; Simple TypeIDs 61 | (def Int64-Type 1) 62 | (def WString-Type 2) 63 | (def WFn-Type 3) 64 | 65 | ;; We're going to cache ints. So instead boxing common ints everytime 66 | ;; we need a boxed in, we will instead cache these ints. This will 67 | ;; save an memory allocation in these cases. 68 | (c/def WInt64-cache nil -> WObject***) 69 | 70 | 71 | ;; Each Fn gets handed itself as the first argument, thus the arg 72 | ;; list item counts seem to be off by one. That being known let's help 73 | ;; ourselves a bit by providing names for three well know arities 74 | 75 | (def TNullaryFn (c/fn-t [WObject*] WObject*)) 76 | (def TUnaryFn (c/fn-t [WObject* WObject*] WObject*)) 77 | (def TBinaryFn (c/fn-t [WObject* WObject* WObject*] WObject*)) 78 | 79 | (def TNullaryFn* (->PointerType TNullaryFn)) 80 | (def TUnaryFn* (->PointerType TUnaryFn)) 81 | (def TBinaryFn* (->PointerType TBinaryFn)) 82 | 83 | ;; We can use a vector as a int to fn type converter 84 | (def argc->fn-t 85 | [TNullaryFn 86 | TUnaryFn 87 | TBinaryFn]) 88 | 89 | ;; Wrapping/unwrapping 90 | 91 | ;; We're about to create common wrap/unwrap functions, using macros. 92 | ;; Once we're done, we're going to have a set of functions that look 93 | ;; something like this: 94 | 95 | (defn- symstr 96 | "Like str but the end result is a symbol" 97 | [& more] 98 | (symbol (apply str (map str more)))) 99 | 100 | (defn gen-wrap-fn 101 | "Generates a wrap function given a wrapped type, a type id, and the 102 | name and type of the value to be wrapped" 103 | [[wtp tpid attr vtp]] 104 | `(c/defn ~(symstr "wrap-" wtp) [~vtp v# ~'-> WObject*] 105 | (c/let [a# (tmalloc ~wtp) ] 106 | (WObject* (-> a# 107 | (c/set :type ~tpid) 108 | (c/set ~attr v#)))))) 109 | 110 | (defn debug [x] 111 | (pprint x) 112 | x) 113 | 114 | (defn gen-unwrap-fn [[wtp tpid attr vtp]] 115 | `(c/defn ~(symstr "unwrap-" wtp) [WObject* v# ~'-> ~vtp] 116 | (c/get ((->PointerType ~wtp) v#) ~attr))) 117 | 118 | 119 | 120 | 121 | (defmacro wrap-types [tps] 122 | (list* 'do 123 | (mapcat 124 | (fn [tp] 125 | [(gen-wrap-fn tp) 126 | (gen-unwrap-fn tp)]) 127 | tps))) 128 | 129 | ;; Use the macros to generate the wrap/unwrap functions 130 | (wrap-types [[WInt64 1 :int64-value Int64] 131 | [WString 2 :str-value Int8*] 132 | [WFn 3 :fn-value Int8*]]) 133 | 134 | 135 | ;; Instead of using wrap-WInt64, we can use cached-WInt64, this will 136 | ;; result in faster creation of wrapped integers for values from -31 137 | ;; to 991 138 | (c/defn cached-WInt64 [Int64 x -> WObject*] 139 | (c/let [drc (c/aget WInt64-cache 0)] 140 | (c/if (c/< x 992) 141 | (c/if (c/> x -32) 142 | (c/aget drc 143 | (c/+ x 32)) 144 | (wrap-WInt64 x)) 145 | (wrap-WInt64 x)))) 146 | 147 | ;; Addition of two WInt64 148 | (c/defn WInt64-+ [WObject* self WObject* a WObject* b -> WObject*] 149 | (cached-WInt64 (c/+ (unwrap-WInt64 a) 150 | (unwrap-WInt64 b)))) 151 | 152 | ;; Comparison of two Int64s 153 | (c/defn WInt64-= [WObject* self WObject* a WObject* b -> WObject*] 154 | (c/if (c/= (unwrap-WInt64 a) 155 | (unwrap-WInt64 b)) 156 | (cached-WInt64 1) 157 | (cached-WInt64 0))) 158 | 159 | ;; Print a WInt64 via libc's printf 160 | (c/defn WInt64-print [WObject* self WObject* a -> WObject*] 161 | (cached-WInt64 (print-Int64 (c/const "%i\n" -> Int8*) 162 | (unwrap-WInt64 a)))) 163 | 164 | ;; Given a WFn, invoke it with no args 165 | (c/defn WFn-invoke0 [WObject* fno -> WObject*] 166 | (->CallPointer (TNullaryFn* (unwrap-WFn fno)) [fno])) 167 | 168 | ;; Given a WFn, invoke it with one arg 169 | (c/defn WFn-invoke1 [WObject* fno WObject* a -> WObject*] 170 | (->CallPointer (TUnaryFn* (unwrap-WFn fno)) [fno a])) 171 | 172 | ;; Given a WFn, invoke it with two args 173 | (c/defn WFn-invoke2 [WObject* fno WObject* a WObject* b -> WObject*] 174 | (->CallPointer (TBinaryFn* (unwrap-WFn fno)) [fno a b])) 175 | 176 | ;; Dispatch to a invoke based on a given argc 177 | (def arg-dispatch 178 | [WFn-invoke0 179 | WFn-invoke1 180 | WFn-invoke2]) 181 | 182 | ;; Generate a call site for a given number of args 183 | (defn invoke [f & args] 184 | (apply (arg-dispatch (count args)) f args)) 185 | 186 | ;; These will hold known symbols during compilation 187 | (def ^:dynamic globals (atom {})) 188 | (def ^:dynamic locals) 189 | 190 | ;; Generate code that wraps a global fn and returns a WFn 191 | (defn wrap-global-fn [f] 192 | (wrap-WFn (Int8* (->Gbl f)))) 193 | 194 | 195 | ;; These are known global fns, we provide two ways to call each 196 | ;; function. Direct is used if we are calling the function directly, 197 | ;; indirect calling is used when we only have a function pointer. The 198 | ;; direct method is most commonly used when the function being called 199 | ;; is referenced by name as the first item in a s-expression. 200 | (def sym-maps 201 | {'+ {:indirect (wrap-global-fn ::WInt64-+) 202 | :direct ::WInt64-+} 203 | '= {:indirect (wrap-global-fn ::WInt64-=) 204 | :direct ::WInt64-=} 205 | 'print {:indirect (wrap-global-fn ::WInt64-print) 206 | :direct ::WInt64-print}}) 207 | 208 | 209 | ;; This is global init code for the entire runtime. 210 | (c/defn init-all [-> Int64] 211 | (c/let [cache (WObject** (GC_malloc 8192))] 212 | (->Store WInt64-cache cache) 213 | (c/dotimes [x 1024] 214 | (c/aset cache 215 | x 216 | (wrap-WInt64 (c/+ x -32)))))) 217 | 218 | ;; This is the main entry point for a simple-lisp program. First, init 219 | ;; th GC, then init our internal runtime, then invoke the -run function 220 | (c/defn ^:exact main [-> Int64] 221 | (GC_init) 222 | (init-all) 223 | (unwrap-WInt64 (WFn-invoke0 (wrap-global-fn :-run)))) 224 | 225 | ;; Given a symbol, try to find where it what it would refer to given 226 | ;; the current context. 227 | (defn resolve-symbol [x] 228 | (let [r (or (locals x) 229 | (@globals x) 230 | (sym-maps x))] 231 | (assert r (str "Could not resolve: " x)) 232 | r)) 233 | 234 | ;; These refer to specal forms, or builtins 235 | (def builtins #{'defn 'if}) 236 | 237 | ;; Dispatch to a given builtin handler 238 | (defmulti compile-builtin (fn [f & args] 239 | (keyword (name f)))) 240 | 241 | ;; Dispatch to an appropriate handler 242 | (defmulti compile-item (fn [x] 243 | (cond 244 | (integer? x) :int 245 | (string? x) :string 246 | (symbol? x) :symbol 247 | (and (seq? x) 248 | (symbol? (first x)) 249 | (builtins (first x))) :builtin 250 | (and (seq? x) 251 | (symbol? (first x))) :call 252 | :else :sexp))) 253 | 254 | ;; Define a new global function. 255 | (defmethod compile-builtin :defn 256 | [_ nm args & body] 257 | (let [new-global {:indirect (wrap-global-fn (name nm)) 258 | :direct (name nm)}] 259 | (swap! globals assoc nm new-global) 260 | (->Fn (name nm) 261 | (argc->fn-t (count args)) 262 | (cons "self" (map name args)) 263 | (binding [locals (merge 264 | {nm new-global} 265 | (zipmap 266 | args 267 | (map #(->Arg %) 268 | (range 1 (inc (count args))))))] 269 | (->Do (mapv compile-item body)))))) 270 | 271 | (defmethod compile-builtin :if 272 | [_ test then else] 273 | (c/if (c/= (unwrap-WInt64 (compile-item test)) 274 | 0) 275 | (compile-item else) 276 | (compile-item then))) 277 | 278 | (defmethod compile-item :symbol 279 | [x] 280 | (resolve-symbol x)) 281 | 282 | (defmethod compile-item :int 283 | [x] 284 | (cached-WInt64 x)) 285 | 286 | (defmethod compile-item :call 287 | [[f & args]] 288 | (let [resolved (resolve-symbol f)] 289 | ;; Try to get a direct way to call the function, otherwise, fall 290 | ;; back to the slower method of using wrapped functions 291 | (if (and (map? resolved) 292 | (:direct resolved)) 293 | (->Call (->Gbl (:direct resolved)) 294 | (concat [(c/const nil -> WObject*)] (mapv compile-item args))) 295 | (apply 296 | invoke 297 | (or (and (map? resolved) 298 | (:indirect resolved)) 299 | resolved) 300 | (mapv compile-item args))))) 301 | 302 | (defmethod compile-item :builtin 303 | [itm] 304 | (apply compile-builtin itm)) 305 | 306 | (defn compile-lisp [data] 307 | 308 | (let [_ (print "Creating Module: ") 309 | module (time (->> 310 | (mapv compile-item data) 311 | (apply c/module ['examples.simple-lisp]))) 312 | _ (print "Building Module: ") 313 | built (time (-> module 314 | to-db 315 | to-llvm-module)) 316 | _ (print "Optimizing: ") 317 | optimized built #_(time (optimize built))] 318 | optimized)) 319 | 320 | (defn -main [program & opts] 321 | (binding [config/*float-type* Float32 322 | config/*int-type* Int64 323 | config/*target* (config/default-target)] 324 | (let [{:keys [filename obj-type]} (apply hash-map (map read-string opts)) 325 | exprs (read-string (str "[" (slurp program) "]")) 326 | optimized (compile-lisp exprs)] 327 | (assert (and filename obj-type) ":obj-type and :filename are required") 328 | 329 | (print "Writing Output file: ") 330 | (time (emit-to-file config/*target* 331 | optimized 332 | {:filename filename 333 | :obj-type obj-type})))) 334 | (println "Finished") 335 | (shutdown-agents) 336 | 0) 337 | 338 | 339 | 340 | -------------------------------------------------------------------------------- /src/examples/vectors.clj: -------------------------------------------------------------------------------- 1 | (ns examples.vectors 2 | (:gen-class) 3 | (:require [criterium.core :as crit]) 4 | (:require [mjolnir.constructors-init :as const] 5 | [mjolnir.types :as types :refer [I8* Int64 Float64 Float64x4 Float64x4*]] 6 | [mjolnir.expressions :refer [build optimize dump ->ConstVector]] 7 | [mjolnir.config :as config] 8 | [mjolnir.targets.target :refer [emit-to-file as-dll]] 9 | [mjolnir.intrinsics :as intr]) 10 | (:alias c mjolnir.constructors) 11 | (:import [examples Vectors])) 12 | 13 | (set! *warn-on-reflection* true) 14 | (set! *unchecked-math* true) 15 | 16 | (definterface vec-interface 17 | (^doubles gen_vector [^long size]) 18 | (^doubles normalize [^doubles arr ^long size])) 19 | 20 | 21 | 22 | (defn clj-square ^double [^double x] 23 | (* x x)) 24 | 25 | (defn clj-vector-length ^double [^doubles v ^long size] 26 | (loop [sum 0.0 27 | idx 0] 28 | (if (< idx size) 29 | (recur (-> (aget v idx) 30 | clj-square 31 | (+ sum)) 32 | (inc idx)) 33 | (Math/sqrt sum)))) 34 | 35 | (def ^vec-interface clj-imp 36 | (reify 37 | vec-interface 38 | (^doubles gen_vector [this ^long size] 39 | (double-array (map double (range size)))) 40 | 41 | (^doubles normalize [this ^doubles v ^long size] 42 | (let [len (clj-vector-length v size)] 43 | (dotimes [idx size] 44 | (aset-double v idx (/ (aget v idx) len))))))) 45 | 46 | 47 | 48 | (defn clj-gen-vector ^doubles [^long size] 49 | (double-array (map double (range size)))) 50 | 51 | 52 | ;;; Mjolnir implementation 53 | #_(set! config/default-float-type Float64) 54 | #_(set! config/default-int-type Int64) 55 | 56 | (def I8** (types/->PointerType I8*)) 57 | 58 | (c/defn ^:extern ^:exact posix_memalign [I8** ptr Int64 alignment Int64 size -> Int64]) 59 | 60 | (c/defn ^:extern mj-create-buffer [Int64 size -> I8*] 61 | (c/using [x (c/malloc I8* 1)] 62 | (posix_memalign (c/bitcast x I8**) 63 | 64 64 | size) 65 | (c/aget x 0))) 66 | 67 | 68 | (c/defn mj-square [Float64x4 x -> Float64x4] 69 | (c/* x x)) 70 | 71 | (c/defn mj-hadd [Float64x4 v -> Float64] 72 | (c/+ (c/eget v 0) 73 | (c/eget v 1) 74 | (c/eget v 2) 75 | (c/eget v 3))) 76 | 77 | (c/defn mj-propagate [Float64 v -> Float64x4] 78 | (-> (c/const [0.0 0.0 0.0 0.0] -> Float64x4) 79 | (c/eset 0 v) 80 | (c/eset 1 v) 81 | (c/eset 2 v) 82 | (c/eset 3 v))) 83 | 84 | (c/defn mj-length [Float64x4* v Int64 size -> Float64] 85 | (c/loop [sum (c/const [0.0 0.0 0.0 0.0] -> Float64x4) 86 | idx 0] 87 | (c/if (c/< idx size) 88 | (c/recur (-> (c/aget v idx) 89 | mj-square 90 | (c/+ sum)) 91 | (c/+ idx 1) 92 | -> Float64) 93 | (intr/llvm-sqrt-f64 (mj-hadd sum))))) 94 | 95 | (c/defn ^:export mj-normalize [Float64x4* v Int64 size -> Float64x4*] 96 | (c/let [len (mj-length v size) 97 | lenv (mj-propagate len)] 98 | (c/loop [idx 0] 99 | (c/if (c/< idx size) 100 | (c/do (c/aset v idx 101 | (-> (c/aget v idx) 102 | (c/fdiv lenv))) 103 | (c/recur (c/+ idx 1) 104 | -> Float64x4*)) 105 | v)))) 106 | 107 | (defn init [] 108 | (def mjolnir-dll 109 | (config/with-config [Int64 Float64 (config/default-target)] 110 | (let [m (c/module ['examples.vectors 111 | 'mjolnir.intrinsics/llvm-sqrt-f64]) 112 | built (optimize (build m)) 113 | bf (emit-to-file config/*target* 114 | built {:filename "vectors2.s" 115 | :output-type :asm 116 | :cpu :core-avx-i}) 117 | _ (dump built) 118 | dll (as-dll config/*target* 119 | built 120 | {:verbose true 121 | :cpu :core-avx-i})] 122 | dll))) 123 | 124 | (def fn-create-buffer (get mjolnir-dll mj-create-buffer)) 125 | (def fn-mj-normalize (get mjolnir-dll mj-normalize))) 126 | 127 | 128 | (comment 129 | 130 | ;;; ptx code 131 | 132 | (c/defn ptx-length [Float64* v Int64 size -> Float64] 133 | (c/loop [sum (c/const 0 Float64) 134 | idx 0] 135 | (c/if (c/< idx size) 136 | (c/recur 137 | (c/+ sum 138 | (c/aget v (c/+ (c/* (ptx/threaddim_x) 139 | idx) 140 | (ptx/threadidx_x))))) 141 | sum -> Float64))) 142 | 143 | (c/defn ptx-normalize [Float64* v Float64* gbl Int64 size -> Float64*] 144 | (ptx/atomic-add gbl (ptx-length v size)) 145 | (ptx/sync-threads) 146 | (c/let [s (ptx/sqrt (aget gbl 0))] 147 | ))) 148 | 149 | (def ^long size (* 1024 1024 16)) 150 | 151 | 152 | (defn -main [] 153 | (let [vec (.gen-vector clj-imp size)] 154 | (println "Testing CLJ Implementation...") 155 | (crit/quick-bench 156 | (do (.normalize clj-imp vec size)))) 157 | (let [vec (Vectors/createBuffer size)] 158 | (println "Testing Java Implementation...") 159 | (crit/quick-bench 160 | (Vectors/normalize vec size))) 161 | (let [vec (fn-create-buffer (* 16 1024 1024 8))] 162 | (println "Testing Mjolnir (SSE) Code...") 163 | (crit/quick-bench 164 | (fn-mj-normalize vec (/ (* 16 1024 1024) 4))))) 165 | -------------------------------------------------------------------------------- /src/mjolnir/config.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.config 2 | (:require [mjolnir.targets.target :as target] 3 | )) 4 | 5 | (def ^:dynamic *target*) 6 | 7 | ;; These set the type that will be used to encode consts for both 8 | ;; integers and floats 9 | (def ^:dynamic *float-type*) 10 | (def ^:dynamic *int-type*) 11 | (def ^:dynamic *gc* nil) 12 | 13 | (def ^:dynamic *builder*) 14 | (def ^:dynamic *module*) 15 | (def ^:dynamic *fn*) 16 | (def ^:dynamic *llvm-fn*) 17 | (def ^:dynamic *locals* {}) 18 | (def ^:dynamic *llvm-locals*) 19 | (def ^:dynamic *llvm-recur-point*) 20 | (def ^:dynamic *llvm-recur-phi*) 21 | (def ^:dynamic *llvm-recur-block*) 22 | (def ^:dynamic *block* (atom nil)) 23 | (def ^:dynamic *recur-point*) 24 | 25 | 26 | (defmacro with-target [[nm target] & body] 27 | `(binding [*target* ~target] 28 | (let [~nm *target*] 29 | ~@body))) 30 | 31 | (defmacro with-config [[int-type float-type target] & body] 32 | `(binding [*int-type* ~int-type 33 | *float-type* ~float-type 34 | *target* ~target] 35 | ~@body)) 36 | 37 | (def default-target-fn (atom nil)) 38 | 39 | (defn default-target [] 40 | (require 'mjolnir.targets.darwin) 41 | (let [init (intern 'mjolnir.targets.darwin 'init-target)] 42 | (init (fn [d-fn] 43 | (reset! default-target-fn d-fn))) 44 | (@default-target-fn))) 45 | 46 | -------------------------------------------------------------------------------- /src/mjolnir/constructors_init.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.constructors-init 2 | (:require [mjolnir.expressions :as exp] 3 | [mjolnir.types :as tp] 4 | [clojure.pprint :refer [pprint]])) 5 | 6 | (def registered-globals (atom {})) 7 | 8 | (defn register-global [ns nm gbl] 9 | (swap! registered-globals assoc-in [ns nm] gbl)) 10 | 11 | (defn c-do [& body] 12 | (exp/->Do body)) 13 | 14 | (defn gen-binops [op exprs] 15 | (reduce (partial exp/->Binop op) 16 | (first exprs) 17 | (next exprs))) 18 | 19 | (defn c-* [& exprs] 20 | (gen-binops :* exprs)) 21 | 22 | (defn c-+ [& exprs] 23 | (gen-binops :+ exprs)) 24 | 25 | (defn c-- [& exprs] 26 | (gen-binops :- exprs)) 27 | 28 | (defn c-div [& exprs] 29 | (gen-binops :div exprs)) 30 | 31 | (defn c-mod [& exprs] 32 | (gen-binops :mod exprs)) 33 | 34 | (defn c-and [& exprs] 35 | (gen-binops :and exprs)) 36 | 37 | #_(defn c-module 38 | [& body] 39 | (exp/->Module (name (gensym "module_")) body)) 40 | 41 | (defn c-if [test then else] 42 | (exp/->If test then else)) 43 | 44 | 45 | (defn c-fn-t [args ret] 46 | #_{:post [(tp/valid? %)]} 47 | (tp/->FunctionType args ret)) 48 | 49 | (defmacro c-fn [name tp args linkage & body] 50 | {:pre [name tp args]} 51 | `(exp/map->Fn {:type ~tp 52 | :arg-names ~(mapv clojure.core/name args) 53 | :linkage ~linkage 54 | :name ~name 55 | :body (let ~(vec (mapcat (fn [x idx] `[~x 56 | (exp/->Arg ~idx)]) 57 | args 58 | (range))) 59 | (if ~(empty? body) 60 | nil 61 | (c-do ~@body)))})) 62 | 63 | (defmacro c-defn [name args & body] 64 | {:pre [(even? (count args))]} 65 | (let [args (partition 2 args) 66 | ret-fn (comp (partial = '->) first) 67 | ret-type (second (first (filter ret-fn args))) 68 | args (remove ret-fn args) 69 | args-map (zipmap (map second args) 70 | (range)) 71 | arg-types (mapv first args) 72 | local-name (clojure.core/name name) 73 | extern-name (if (string? (:exact (meta name))) 74 | (:exact (meta name)) 75 | (clojure.core/name name))] 76 | (assert ret-type (str "Compiling: " name "No return type given, did you forget the -> type?")) 77 | `(let [nsname# (.getName ~'*ns*) 78 | ~'_ (defn ~name 79 | [& args#] 80 | (exp/->Call (exp/->Gbl (if ~(:exact (meta name)) 81 | ~extern-name 82 | (str nsname# "/" ~(clojure.core/name name)))) 83 | (vec args#))) 84 | f# (c-fn (if ~(:exact (meta name)) 85 | ~extern-name 86 | (str nsname# "/" ~(clojure.core/name name))) 87 | (c-fn-t ~(mapv first args) ~ret-type) 88 | ~(mapv second args) 89 | ~(when (:extern (meta name)) :extern) 90 | ~@body)] 91 | (register-global nsname# ~local-name f#) 92 | ))) 93 | 94 | (defmacro c-const [val arrow tp] 95 | (assert (= arrow '->) "missing '-> before type") 96 | `(exp/->Const ~tp ~val)) 97 | 98 | (defn c-or [& exprs] 99 | (gen-binops :or exprs)) 100 | 101 | (defn c-= [a b] 102 | (exp/->Cmp := a b)) 103 | 104 | (defn c-< [a b] 105 | (exp/->Cmp :< a b)) 106 | 107 | (defn c-> [a b] 108 | (exp/->Cmp :> a b)) 109 | 110 | (defn c-<= [a b] 111 | (exp/->Cmp :<= a b)) 112 | 113 | (defn c->= [a b] 114 | (exp/->Cmp :>= a b)) 115 | 116 | (defn c-not= [a b] 117 | (exp/->Cmp :not= a b)) 118 | 119 | (defn c-dec [a] 120 | (c-+ a -1)) 121 | 122 | (defn c-inc [a] 123 | (c-+ a 1)) 124 | 125 | (defn c-callp [f & args] 126 | (exp/->CallPointer f args)) 127 | 128 | (defn c-module [includes & body] 129 | (doto (exp/->Module (-> (reduce (fn [a x] 130 | (if (namespace x) 131 | (let [exp (get-in @registered-globals 132 | [(symbol (namespace x)) 133 | (name x)])] 134 | (assert exp (str "Can't find include " 135 | (symbol (namespace x)) 136 | " " 137 | (name x) 138 | " " 139 | (keys @registered-globals) 140 | " " 141 | (keys (@registered-globals 142 | (symbol (namespace x)))))) 143 | (conj a exp)) 144 | (concat a 145 | (vals (@registered-globals x))))) 146 | [] 147 | includes) 148 | (concat body) 149 | vec)) 150 | #_println)) 151 | 152 | (defn c-aset [arr idx val] 153 | (exp/->ASet arr idx val)) 154 | 155 | (defn c-aget [arr idx] 156 | (exp/->AGet arr idx)) 157 | 158 | (defn c-nth [arr idx] 159 | (exp/->Nth arr idx)) 160 | 161 | (defn c-eget [vec idx] 162 | (exp/->EGet vec idx)) 163 | 164 | (defn c-eset [vec idx val] 165 | (exp/->ESet vec idx val)) 166 | 167 | (defn c-cast [tp a] 168 | (exp/->Cast tp a)) 169 | 170 | (defn c-size-of [tp] 171 | (exp/->SizeOf tp)) 172 | 173 | (defmacro c-local [nm] 174 | `(exp/->Local ~(name nm))) 175 | 176 | (defmacro c-loop [binds & body] 177 | (let [sbinds (partition 2 binds)] 178 | `(exp/->Loop ~(vec (map (fn [[nm bind]] 179 | [(name nm) 180 | bind]) 181 | sbinds)) 182 | (let [~@(mapcat (fn [[nm _]] 183 | [nm (list 'mjolnir.expressions/->Local (name nm))]) 184 | sbinds)] 185 | (c-do ~@body))))) 186 | 187 | (defn c-recur [& items] 188 | (exp/->Recur (vec items))) 189 | 190 | (defmacro c-dotimes [[sym times] & body] 191 | `(exp/->Loop [[~(name sym) 0]] 192 | (let [~sym (c-local ~sym)] 193 | (exp/->Do [~@body 194 | (c-if (c-= ~times ~sym) 195 | 0 196 | (c-recur (c-+ 1 ~sym)))])))) 197 | 198 | (defmacro c-let [bindings & body] 199 | (reduce (fn [a [local binding]] 200 | (let [s (name (gensym (str (name local) "_")))] 201 | `(exp/->Let ~(name local) ~binding 202 | (let [~local (c-local ~local)] 203 | ~a)))) 204 | `(exp/->Do ~(vec body)) 205 | (reverse (partition 2 bindings)))) 206 | 207 | (defn c-malloc 208 | "Mallocs a instance of the given type" 209 | [type] 210 | (exp/->Malloc type)) 211 | 212 | (defn c-free 213 | "Constructs an expression that calls free on the given pointer" 214 | [val] 215 | (exp/->Free val)) 216 | 217 | (defmacro c-using [[sym resource] & body] 218 | `(c-let [~sym ~resource 219 | ret# (c-do ~@body)] 220 | (c-free ~sym) 221 | ret#)) 222 | 223 | 224 | (defn c-struct [name opts] 225 | (assoc (tp/->StructType name (:extends opts) (:members opts)) 226 | :gc (:gc opts))) 227 | 228 | (defn- make-getter [[tp nm]] 229 | `(defn ~(symbol (str "-" (name nm))) 230 | [x#] 231 | (c-get x# ~(-> nm name keyword)))) 232 | 233 | (defmacro c-defstruct [nm & opts] 234 | (let [opts (apply hash-map opts) 235 | extends (:extends opts) 236 | members (:members opts) 237 | parted (partition 2 members)] 238 | `(do (def ~nm (c-struct (str (.getName ~'*ns*) "/" ~(name nm)) 239 | ~(merge 240 | opts 241 | {:extends extends 242 | :members (vec (map 243 | (fn [[tp nm]] 244 | [tp (keyword (name nm))]) 245 | parted))}))) 246 | ~@(map make-getter 247 | parted)))) 248 | 249 | (defn c-set 250 | "Creates an ->Set expression. ptr is a pointer to a struct, attr is the 251 | keyword of the member to set and val is value to set the member to." 252 | [ptr attr val] 253 | (exp/->Set ptr attr val)) 254 | 255 | (defn c-get 256 | "Creates a ->Get expression. ptr is a pointer to a struct and attr is the 257 | keyword of the member to access." 258 | [ptr attr] 259 | (exp/->Get ptr attr)) 260 | 261 | (defn c-new 262 | "Constructs a new struct (using malloc), and sets the first (count vals) values 263 | to the values provide." 264 | ([tp] 265 | (exp/->New tp)) 266 | ([tp cnt] 267 | (exp/->NewArray tp cnt))) 268 | 269 | (defn c-global [nm tp val] 270 | (exp/->Global nm tp val)) 271 | 272 | (defn c-atomic [ptr op val] 273 | (exp/->Atomic ptr op val)) 274 | 275 | (defmacro c-def [nm tp val] 276 | `(let [nsname# (.getName ~'*ns*)] 277 | (def ~nm (exp/->Gbl (str nsname# "/" ~(name nm)))) 278 | (register-global 279 | nsname# 280 | ~(name nm) 281 | (c-global (str nsname# "/" ~(name nm)) 282 | ~tp 283 | ~val)))) 284 | 285 | 286 | (defmacro c-for [[var [from to step]] & body] 287 | `(c-let [to# ~to] 288 | (c-loop [~var ~from] 289 | (c-if (c-< ~var to#) 290 | (c-do ~@body 291 | (c-recur (c-+ ~var ~step))) 292 | ~var)))) 293 | 294 | 295 | 296 | 297 | ;; Black magic is here 298 | (let [ns (create-ns 'mjolnir.constructors)] 299 | (doseq [[nm var] (ns-publics *ns*)] 300 | (when (= [\c \-] (take 2 (name nm))) 301 | (let [nvar (intern ns 302 | (symbol (apply str (drop 2 (name nm)))) 303 | @var)] 304 | (.setMeta nvar (meta var)) 305 | nvar)))) 306 | 307 | 308 | (defn- constructor [sym] 309 | (let [sym (if (= (name sym) "/") 310 | (symbol "div") 311 | sym) 312 | s (symbol (str "c-" (name sym))) 313 | var ((ns-publics (the-ns 'mjolnir.constructors-init)) s)] 314 | var)) 315 | 316 | (defn- constructor? [sym] 317 | (not (nil? (constructor sym)))) 318 | 319 | (declare convert-form) 320 | 321 | (defn- convert-form-1 [x] 322 | (cond 323 | (and (seq? x) 324 | (symbol? (first x)) 325 | (> (count (name (first x))) 2) 326 | (= (.substring (name (first x)) 0 2) ".-")) 327 | (convert-form (list 'get 328 | (fnext x) 329 | (keyword (.substring (name (first x)) 2)))) 330 | 331 | (and (seq? x) 332 | (keyword? (first x))) 333 | `(exp/->Call 334 | (exp/->Gbl ~(first x)) 335 | ~(mapv convert-form-1 (next x))) 336 | 337 | (seq? x) 338 | (convert-form x) 339 | 340 | (vector? x) 341 | (into [] (convert-form x)) 342 | 343 | (map? x) 344 | (into {} (convert-form x)) 345 | 346 | (set? x) 347 | (into #{} (convert-form x)) 348 | 349 | (and (symbol? x) 350 | (constructor? x)) 351 | (let [s 352 | (symbol "mjolnir.constructors-init" (str "c-" (if (= (name x) "/") 353 | "div" 354 | (symbol x))))] 355 | s) 356 | 357 | 358 | :else 359 | x)) 360 | 361 | (defn convert-form [body] 362 | (doall (map convert-form-1 body))) 363 | 364 | (defmacro defnf [& body] 365 | (cons 366 | 'mjolnir.constructors-init/c-defn 367 | (doall (map convert-form-1 body)))) 368 | -------------------------------------------------------------------------------- /src/mjolnir/core.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.core 2 | (:require 3 | [mjolnir.types :refer [Int64 Float64]] 4 | [mjolnir.targets.target :refer [as-dll as-exe]] 5 | [mjolnir.expressions :as expr] 6 | [mjolnir.inference :refer [infer-all]] 7 | [mjolnir.validation :refer [validate]] 8 | [clojure.test :refer :all] 9 | [datomic.api :refer [q db] :as d] 10 | [mjolnir.config :refer [*gc* *int-type* *float-type* *target* default-target]] 11 | [mjolnir.ssa :refer :all] 12 | [mjolnir.gc :as gc] 13 | [mjolnir.gc.boehm :refer [->BoehmGC]] 14 | [mjolnir.llvm-builder :refer [build dump optimize verify]])) 15 | 16 | (defn to-db [m] 17 | (let [conn (new-db)] 18 | (-> (gen-plan 19 | [_ (add-to-plan m)] 20 | nil) 21 | (get-plan conn) 22 | commit) 23 | (when *gc* 24 | (gc/add-globals *gc* conn)) 25 | {:conn conn})) 26 | 27 | (defn to-llvm-module 28 | ([m] 29 | (to-llvm-module m false)) 30 | ([{:keys [conn] :as ctx} dump?] 31 | (infer-all conn) 32 | (validate (db conn)) 33 | (let [built (build (db conn))] 34 | (verify built) 35 | (optimize built) 36 | (when dump? 37 | (dump built)) 38 | (assoc ctx :module built)))) 39 | 40 | (defn to-dll [{:keys [module] :as ctx}] 41 | (assoc ctx :dll (as-dll (default-target) module {:verbose true}))) 42 | 43 | (defn get-fn [{:keys [conn module dll]} ctr] 44 | (let [nm (-> (ctr) :fnc :name) 45 | _ (assert nm (str "Cant get name " nm)) 46 | db-val (db conn) 47 | ent (ffirst (q '[:find ?id 48 | :in $ ?nm 49 | :where 50 | [?id :fn/name ?nm]] 51 | db-val 52 | nm)) 53 | _ (assert ent (str "Can't find " nm)) 54 | ent (d/entity db-val ent)] 55 | (assert ent (pr-str "Can't find " nm)) 56 | (get dll ent))) 57 | 58 | (defn build-module [m] 59 | (-> (to-db m) 60 | (to-llvm-module))) 61 | 62 | (defn build-default-module 63 | ([m] 64 | (build-default-module m false)) 65 | ([m dump?] 66 | (binding [*int-type* Int64 67 | *float-type* Float64 68 | *gc* (->BoehmGC) 69 | *target* (default-target)] 70 | (-> (to-db m) 71 | (to-llvm-module dump?))))) 72 | 73 | (defn to-exe 74 | [{:keys [module] :as exe} filename & opts] 75 | (as-exe (default-target) module (merge 76 | (apply hash-map opts) 77 | {:verbose true 78 | :filename filename}))) 79 | 80 | 81 | 82 | -------------------------------------------------------------------------------- /src/mjolnir/expressions.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.expressions 2 | (:require [mjolnir.types :refer :all] 3 | [mjolnir.ssa :as ssa :refer :all] 4 | [mjolnir.llvmc :as llvm] 5 | [mjolnir.config :refer :all] 6 | [clojure.java.shell :as shell] 7 | [clojure.string :as string] 8 | [mjolnir.targets.target :as target]) 9 | (:import [com.sun.jna Native Pointer] 10 | [datomic.db.DbId])) 11 | 12 | (def genname (comp name gensym)) 13 | 14 | (defprotocol Expression 15 | (return-type [this]) 16 | (build [this])) 17 | 18 | 19 | (defn Expression? [this] 20 | (extends? Expression (type this))) 21 | 22 | (defprotocol SSAWriter 23 | (write-ssa [this])) 24 | 25 | 26 | 27 | (defn- const-data [val] 28 | (cond 29 | (integer? val) {:const/int-value val} 30 | (float? val) {:const/float-value val} 31 | (instance? java.lang.Boolean val) {:const/int-value (int val)})) 32 | 33 | (defrecord Const [type val] 34 | SSAWriter 35 | (write-ssa [this] 36 | (gen-plan 37 | [tp (add-to-plan type) 38 | const (add-instruction :inst.type/const 39 | (merge 40 | (const-data val) 41 | {:const/type tp}) 42 | key)] 43 | const))) 44 | 45 | (defrecord Cast [tp expr] 46 | SSAWriter 47 | (write-ssa [this] 48 | (gen-plan 49 | [tp-id (add-to-plan tp) 50 | expr-id (write-ssa expr) 51 | casted (add-instruction :inst.type/cast 52 | {:inst.arg/arg0 expr-id 53 | :node/return-type tp-id 54 | :inst.cast/type :inst.cast/unknown})] 55 | casted))) 56 | 57 | (defmethod construct-expr :->Cast 58 | [tp & args] 59 | (apply ->Cast args)) 60 | 61 | (def cmp-maps 62 | {:int {:= llvm/LLVMIntEQ 63 | :!= llvm/LLVMIntNE 64 | :> llvm/LLVMIntSGT 65 | :< llvm/LLVMIntSLT 66 | :<= llvm/LLVMIntSLE 67 | :>= llvm/LLVMIntSGE} 68 | :float {:= llvm/LLVMRealOEQ 69 | :!= llvm/LLVMRealONE 70 | :> llvm/LLVMRealOGT 71 | :< llvm/LLVMRealOLT 72 | :<= llvm/LLVMRealOLE 73 | :>= llvm/LLVMRealOGE}}) 74 | 75 | (defrecord Cmp [pred a b] 76 | SSAWriter 77 | (write-ssa [this] 78 | (let [pred (keyword "inst.cmp.pred" (name pred))] 79 | (gen-plan 80 | [tp (add-to-plan Int1) 81 | lh (write-ssa a) 82 | rh (write-ssa b) 83 | nd (add-instruction :inst.type/cmp 84 | {:node/return-type tp 85 | :inst.arg/arg0 lh 86 | :inst.arg/arg1 rh 87 | :inst.cmp/pred pred} 88 | nil)] 89 | nd)))) 90 | 91 | (defrecord Not [a] 92 | Validatable 93 | (validate [this] 94 | (assure (valid? a)) 95 | (assure-same-type (return-type a) Int1)) 96 | Expression 97 | (return-type [this] 98 | Int1) 99 | (build [this] 100 | (llvm/BuildNot *builder* (build a) "not_"))) 101 | 102 | (defprotocol IFunctionExpression 103 | (argument [this idx] "Get an expression for the given argument")) 104 | 105 | (defprotocol NamedExpression 106 | (get-name [this])) 107 | 108 | 109 | (defrecord Arg [idx] 110 | SSAWriter 111 | (write-ssa [this] 112 | (gen-plan 113 | [this-id (add-instruction :inst.type/arg 114 | {:inst.arg/idx idx} 115 | this)] 116 | this-id))) 117 | 118 | (defn full-name [n] 119 | (cond (string? n) n 120 | (and (keyword? n) (namespace n)) (str (namespace n) "/" (name n)) 121 | (keyword? n) (name n) 122 | :else (assert false (str "Can't get name of " (pr-str n))))) 123 | 124 | (defrecord GetGlobal [name tp] 125 | Validatable 126 | (validate [this] 127 | (assure (or (string? name) 128 | (keyword? name))) 129 | (assure (type? tp))) 130 | Expression 131 | (return-type [this] 132 | tp) 133 | (build [this] 134 | (let [val (if (FunctionType? tp) 135 | (llvm/GetNamedFunction *module* (full-name name)) 136 | (llvm/GetNamedGlobal *module* (full-name name)))] 137 | (assert val (str "Global not found " (full-name name))) 138 | 139 | val))) 140 | 141 | (defrecord Gbl [name] 142 | SSAWriter 143 | (write-ssa [this] 144 | (gen-plan 145 | [gbl (add-instruction :inst.type/gbl 146 | {:inst.gbl/name (full-name name)} 147 | this)] 148 | gbl))) 149 | 150 | (extend-type clojure.lang.Keyword 151 | SSAWriter 152 | (write-ssa [this] 153 | (write-ssa (->Gbl this)))) 154 | 155 | 156 | 157 | (defrecord SizeOf [tp] 158 | Validatable 159 | (validate [this] 160 | (assure (type? tp))) 161 | Expression 162 | (return-type [this] 163 | Int64) 164 | (build [this] 165 | (llvm/SizeOf (llvm-type tp))) 166 | SSAWriter 167 | (write-ssa [this] 168 | (gen-plan 169 | [ret-type (add-to-plan *int-type*) 170 | tp-id (add-to-plan tp) 171 | this-id (add-instruction :inst.type/sizeof 172 | {:inst.sizeof/type tp-id 173 | :node/return-type ret-type})] 174 | this-id))) 175 | 176 | (def binop-maps 177 | {:+ :inst.binop.type/add 178 | :- :inst.binop.type/sub 179 | :* :inst.binop.type/mul 180 | :mod :inst.binop.type/mod 181 | :div :inst.binop.type/div 182 | :and :inst.binop.type/and 183 | :or :inst.binop.type/or}) 184 | 185 | 186 | 187 | (defrecord Binop [op lh rh] 188 | SSAWriter 189 | (write-ssa [this] 190 | (assert (binop-maps op) (str "Invalid binop")) 191 | (gen-plan 192 | [lh-id (write-ssa lh) 193 | rh-id (write-ssa rh) 194 | inst (add-instruction :inst.type/binop 195 | {:inst.arg/arg0 lh-id 196 | :inst.arg/arg1 rh-id 197 | :inst.binop/type (binop-maps op)} 198 | this)] 199 | inst))) 200 | 201 | 202 | (defprotocol GlobalExpression 203 | (stub-global [this])) 204 | 205 | (defn GlobalExpression? [exp] 206 | (extends? GlobalExpression (type exp))) 207 | 208 | (defrecord Fn [name type arg-names body] 209 | IToPlan 210 | (add-to-plan [this] 211 | (gen-plan 212 | [type-id (add-to-plan type) 213 | args (assert-all (map (fn [idx name] 214 | (let [a {:argument/name name 215 | :argument/idx idx}] 216 | [a a])) 217 | (range) 218 | arg-names)) 219 | head-node (assert-seq args) 220 | fn-id (assert-entity (merge {:node/type :node.type/fn 221 | :fn/type type-id 222 | :fn/name name} 223 | (when head-node 224 | {:fn/argument-names head-node})) 225 | this) 226 | _ (assoc-in-plan [:state :fn] fn-id) 227 | _ (if body 228 | (gen-plan 229 | [block-id (add-entry-block fn-id) 230 | body-id (write-ssa body) 231 | ret-id (terminate-block :inst.type/return-val body-id)] 232 | ret-id) 233 | (mark-extern-fn fn-id))] 234 | [fn-id]))) 235 | 236 | (defrecord Module [body] 237 | IToPlan 238 | (add-to-plan [this] 239 | (gen-plan 240 | [ids (add-all (map add-to-plan body))] 241 | ids))) 242 | 243 | (defrecord If [test then else] 244 | SSAWriter 245 | (write-ssa [this] 246 | (gen-plan 247 | [fnc (get-in-plan [:state :fn]) 248 | 249 | test-id (write-ssa test) 250 | test-block (get-block) 251 | 252 | pre-then-block (add-block fnc "then") 253 | _ (set-block pre-then-block) 254 | then-val (write-ssa then) 255 | post-then-block (get-block) 256 | then-terminated? (terminated? post-then-block) 257 | 258 | pre-else-block (add-block fnc "else") 259 | _ (set-block pre-else-block) 260 | else-val (write-ssa else) 261 | post-else-block (get-block) 262 | else-terminated? (terminated? post-else-block) 263 | 264 | merge-block (add-block fnc "merge") 265 | _ (set-block merge-block) 266 | phi-val (add-phi) 267 | 268 | _ (set-block test-block) 269 | br-id (terminate-block :inst.type/br test-id pre-then-block pre-else-block) 270 | 271 | _ (if then-terminated? 272 | (no-op) 273 | (gen-plan 274 | [_ (set-block post-then-block) 275 | _ (terminate-block :inst.type/jmp merge-block) 276 | _ (add-to-phi phi-val post-then-block then-val)] 277 | nil)) 278 | 279 | _ (if else-terminated? 280 | (no-op) 281 | (gen-plan 282 | [_ (set-block post-else-block) 283 | _ (terminate-block :inst.type/jmp merge-block) 284 | _ (add-to-phi phi-val post-else-block else-val)] 285 | nil)) 286 | 287 | _ (set-block merge-block)] 288 | phi-val))) 289 | 290 | (defrecord Call [fnc args] 291 | SSAWriter 292 | (write-ssa [this] 293 | (gen-plan 294 | [fnc (write-ssa fnc) 295 | lst (add-all (map write-ssa args)) 296 | call-id (add-instruction :inst.type/call 297 | (reduce 298 | (fn [acc [idx id]] 299 | (assoc acc (idx->arg idx) id)) 300 | {:inst.call/fn fnc} 301 | (map vector 302 | (range) 303 | lst)) 304 | this)] 305 | call-id))) 306 | 307 | (defrecord CallPointer [fnc args] 308 | Expression 309 | (return-type [this] 310 | (:ret-type (etype (return-type fnc)))) 311 | (build [this] 312 | (llvm/BuildCall *builder* 313 | (build fnc) 314 | (llvm/map-parr build args) 315 | (count args) 316 | (genname "call_"))) 317 | SSAWriter 318 | (write-ssa [this] 319 | (gen-plan 320 | [fn-id (write-ssa fnc) 321 | arg-ids (add-all (map write-ssa args)) 322 | this-id (add-instruction :inst.type/callp 323 | (reduce 324 | (fn [acc [idx id]] 325 | (assoc acc (idx->arg idx) id)) 326 | {:inst.callp/fn fn-id} 327 | (map vector 328 | (range) 329 | arg-ids)))] 330 | this-id))) 331 | 332 | (defrecord Local [nm] 333 | SSAWriter 334 | (write-ssa [this] 335 | (gen-plan 336 | [locals (get-binding :locals) 337 | p (get-in-plan [:bindings])] 338 | (let [a (locals nm)] 339 | (assert a (str "Can't find local " nm " in " locals)) 340 | a)))) 341 | 342 | 343 | (defrecord Loop [itms body] 344 | SSAWriter 345 | (write-ssa [this] 346 | (gen-plan 347 | [fnc (get-in-plan [:state :fn]) 348 | itm-ids (add-all (map (comp write-ssa second) itms)) 349 | recur-pnt (add-block fnc "body") 350 | _ (terminate-block :inst.type/jmp recur-pnt) 351 | prev-block (get-block) 352 | _ (set-block recur-pnt) 353 | phis (add-all (map (fn [x] (add-phi)) 354 | (range (count itms)))) 355 | _ (add-all (map (fn [phi-node val] 356 | (add-to-phi phi-node prev-block val)) 357 | phis 358 | itm-ids)) 359 | _ (apply push-alter-binding :locals assoc (mapcat (fn [[nm _] val] 360 | [nm val]) 361 | itms 362 | phis)) 363 | _ (push-binding :recur recur-pnt) 364 | _ (push-binding :recur-phis phis) 365 | return-val (write-ssa body) 366 | _ (pop-binding :recur-phis) 367 | _ (pop-binding :recur) 368 | _ (pop-binding :locals) 369 | end-block (add-block fnc "end") 370 | _ (terminate-block :inst.type/jmp end-block) 371 | _ (set-block end-block)] 372 | return-val))) 373 | 374 | (defrecord Let [nm bind body] 375 | SSAWriter 376 | (write-ssa [this] 377 | (gen-plan 378 | [bind-id (write-ssa bind) 379 | _ (push-alter-binding :locals assoc nm bind-id) 380 | val (write-ssa body) 381 | _ (pop-binding :locals)] 382 | val))) 383 | 384 | (defrecord Malloc [type] 385 | SSAWriter 386 | (write-ssa [this] 387 | (gen-plan 388 | [tp-id (add-to-plan type) 389 | inst-id (add-instruction :inst.type/malloc 390 | {:inst.malloc/type tp-id 391 | :node/return-type tp-id})] 392 | inst-id))) 393 | 394 | (defrecord New [type] 395 | SSAWriter 396 | (write-ssa [this] 397 | (gen-plan 398 | [tp-id (add-to-plan type) 399 | ptr-type (add-to-plan (->PointerType type)) 400 | size-id (write-ssa (->SizeOf type)) 401 | inst-id (add-instruction :inst.type/new 402 | {:inst.new/type tp-id 403 | :inst.arg/arg0 size-id 404 | :node/return-type ptr-type})] 405 | inst-id))) 406 | 407 | (defrecord NewArray [type count] 408 | SSAWriter 409 | (write-ssa [this] 410 | (gen-plan 411 | [tp-id (add-to-plan type) 412 | ptr-type (add-to-plan (->PointerType type)) 413 | count-id (write-ssa count) 414 | size-id (write-ssa (->Binop :* count-id (->SizeOf type))) 415 | inst-id (add-instruction :inst.type/new 416 | {:inst.new/type tp-id 417 | :inst.new/count count-id 418 | :inst.arg/arg0 size-id 419 | :node/return-type ptr-type})] 420 | inst-id))) 421 | 422 | (defrecord Free [itm] 423 | SSAWriter 424 | (write-ssa [this] 425 | (gen-plan 426 | [itm (write-ssa itm) 427 | void (add-to-plan VoidT) 428 | inst-id (add-instruction :inst.type/free 429 | {:inst.arg/arg0 itm 430 | :node/return-type void})] 431 | inst-id))) 432 | 433 | (defrecord Atomic [ptr op arg] 434 | SSAWriter 435 | (write-ssa [this] 436 | (gen-plan 437 | [ptr-id (write-ssa ptr) 438 | arg-id (write-ssa arg) 439 | inst-id (add-instruction :inst.type/atomic 440 | {:inst.arg/arg0 ptr-id 441 | :inst.arg/arg1 arg-id 442 | :inst.atomic/op op})] 443 | inst-id))) 444 | 445 | (defrecord ASet [arr idx val] 446 | SSAWriter 447 | (write-ssa [this] 448 | (gen-plan 449 | [arr-id (write-ssa arr) 450 | idx-id (write-ssa idx) 451 | val-id (write-ssa val) 452 | inst-id (add-instruction :inst.type/aset 453 | {:inst.arg/arg0 arr-id 454 | :inst.arg/arg1 idx-id 455 | :inst.arg/arg2 val-id})] 456 | inst-id))) 457 | 458 | (defrecord AGet [arr idx] 459 | SSAWriter 460 | (write-ssa [this] 461 | (gen-plan 462 | [arr-id (write-ssa arr) 463 | idx-id (write-ssa idx) 464 | inst-id (add-instruction :inst.type/aget 465 | {:inst.arg/arg0 arr-id 466 | :inst.arg/arg1 idx-id})] 467 | inst-id))) 468 | 469 | (defrecord Nth [arr idx] 470 | SSAWriter 471 | (write-ssa [this] 472 | (gen-plan 473 | [arr-id (write-ssa arr) 474 | idx-id (write-ssa idx) 475 | inst-id (add-instruction :inst.type/nth 476 | {:inst.arg/arg0 arr-id 477 | :inst.arg/arg1 idx-id})] 478 | inst-id))) 479 | 480 | (defrecord Set [ptr member val] 481 | Validatable 482 | (validate [this] 483 | (assure (valid? ptr)) 484 | (assure (keyword? member)) 485 | (assure (valid? val)) 486 | (assure (pointer-type? (return-type ptr))) 487 | (let [etp (etype (return-type ptr)) 488 | mt (member-idx etp member)] 489 | (assert (identity mt) (vector (flatten-struct (return-type ptr)) 490 | (return-type ptr))) 491 | (assure-same-type (first (nth (flatten-struct etp) mt)) 492 | (return-type val)))) 493 | 494 | Expression 495 | (return-type [this] 496 | (return-type ptr)) 497 | (build [this] 498 | (let [etp (etype (return-type ptr)) 499 | idx (member-idx etp 500 | member) 501 | _ (assert idx (pr-str "Idx error, did you validate first? " ptr " " member)) 502 | bptr (build ptr) 503 | cptr (build (->Cast (->PointerType etp) ptr)) 504 | gep (llvm/BuildStructGEP *builder* cptr idx (genname "set_"))] 505 | (llvm/BuildStore *builder* (build val) gep) 506 | bptr)) 507 | SSAWriter 508 | (write-ssa [this] 509 | (gen-plan 510 | [ptr-id (write-ssa ptr) 511 | val-id (write-ssa val) 512 | inst-id (add-instruction :inst.type/set 513 | {:inst.arg/arg0 ptr-id 514 | :inst.arg/arg1 val-id 515 | :inst.set/member member})] 516 | ptr-id))) 517 | 518 | 519 | (defrecord Store [ptr val] 520 | Validatable 521 | (validate [this] 522 | (assure (valid? ptr)) 523 | (assure (valid? val))) 524 | Expression 525 | (return-type [this] 526 | (return-type ptr)) 527 | (build [this] 528 | (build (->ASet ptr [0] val))) 529 | SSAWriter 530 | (write-ssa [this] 531 | (write-ssa (->ASet ptr 0 val)) 532 | #_(gen-plan 533 | [ptr-id (write-ssa ptr) 534 | val-id (write-ssa val) 535 | this-id (add-instruction :inst.type/store 536 | {:inst.arg/arg0 ptr-id 537 | :inst.arg/arg1 val-id})] 538 | this-id))) 539 | 540 | 541 | (defrecord Get [ptr member] 542 | Expression 543 | (return-type [this] 544 | (let [idx (member-idx (etype (return-type ptr)) 545 | member)] 546 | (-> ptr return-type etype flatten-struct (nth idx) first))) 547 | (build [this] 548 | (let [etp (etype (return-type ptr)) 549 | idx (member-idx etp 550 | member) 551 | _ (assert idx "Idx error, did you validate first?") 552 | cptr (build (->Cast (->PointerType etp) ptr)) 553 | gep (llvm/BuildStructGEP *builder* cptr idx (genname "get_"))] 554 | (llvm/BuildLoad *builder* gep (genname "load_")))) 555 | SSAWriter 556 | (write-ssa [this] 557 | (gen-plan 558 | [ptr-id (write-ssa ptr) 559 | inst-id (add-instruction :inst.type/get 560 | {:inst.arg/arg0 ptr-id 561 | :inst.get/member member})] 562 | inst-id))) 563 | 564 | 565 | (defrecord EGet [vec member] 566 | Validatable 567 | (validate [this] 568 | (assure (vector-type? (return-type vec))) 569 | (assure (integer? member)) 570 | (assure (< member (:length (return-type vec))))) 571 | Expression 572 | (return-type [this] 573 | (etype (return-type vec))) 574 | (build [this] 575 | (llvm/BuildExtractElement *builder* 576 | (build vec) 577 | (encode-const Int32 member) 578 | (genname "eget_")))) 579 | 580 | (defrecord ESet [vec member val] 581 | Validatable 582 | (validate [this] 583 | (assure (vector-type? (return-type vec))) 584 | (assure (integer? member)) 585 | (assure-same-type (etype (return-type vec)) 586 | (return-type val)) 587 | (assure (< member (:length (return-type vec))))) 588 | Expression 589 | (return-type [this] 590 | (return-type vec)) 591 | (build [this] 592 | (llvm/BuildInsertElement *builder* 593 | (build vec) 594 | (build val) 595 | (encode-const Int32 member) 596 | (genname "eget_")))) 597 | 598 | #_(defrecord New [tp vals] 599 | Validatable 600 | (validate [this] 601 | (assure (StructType? tp)) 602 | (assure (= (count (flatten-struct tp)) (count vals))) 603 | (doall (map (fn [[tp name] o] 604 | (assure-same-type tp (return-type o))) 605 | (flatten-struct tp) 606 | vals))) 607 | Expression 608 | (return-type [this] 609 | (->PointerType tp)) 610 | (build [this] 611 | (let [malloc (llvm/BuildMalloc *builder* (llvm-type tp) (genname "new_")) 612 | members (flatten-struct tp)] 613 | (doseq [idx (range (count vals))] 614 | (let [gep (llvm/BuildStructGEP *builder* 615 | malloc 616 | idx 617 | (genname "gep_"))] 618 | (llvm/BuildStore *builder* (build (nth vals idx)) gep))) 619 | malloc))) 620 | 621 | (defrecord Recur [items] 622 | SSAWriter 623 | (write-ssa [this] 624 | (gen-plan 625 | [item-ids (add-all (map write-ssa items)) 626 | this-block (get-block) 627 | phis (get-binding :recur-phis) 628 | _ (add-all (map (fn [phi val] 629 | (add-to-phi phi this-block val)) 630 | phis 631 | item-ids)) 632 | recur-pnt (get-binding :recur) 633 | _ (terminate-block :inst.type/jmp recur-pnt)] 634 | nil))) 635 | 636 | (defrecord Do [body] 637 | SSAWriter 638 | (write-ssa [this] 639 | (gen-plan 640 | [body-ids (add-all (map write-ssa body))] 641 | (last body-ids)))) 642 | 643 | (defrecord Global [name type val] 644 | IToPlan 645 | (add-to-plan [this] 646 | (gen-plan 647 | [type-id (add-to-plan type) 648 | this-id (assert-entity (merge {:node/type :node.type/global 649 | :global/name name 650 | :global/type type-id} 651 | (const-data val)))] 652 | this-id))) 653 | 654 | (defn kw->Global [module kw] 655 | (assert module "No Module Given") 656 | (assert kw "No KW name given") 657 | (let [f (->> module 658 | :body 659 | (filter #(= (:name %) 660 | (name kw))) 661 | first) 662 | 663 | gg (->GetGlobal (name kw) 664 | (:type f))] 665 | (assert f (str "Global not found " kw)) 666 | f)) 667 | 668 | (defn Module? [mod] 669 | (instance? Module mod)) 670 | 671 | (defn compile-module [module] 672 | {:pre [(Module? module)]} 673 | (build module)) 674 | 675 | 676 | (extend-type java.lang.Long 677 | SSAWriter 678 | (write-ssa [this] 679 | (write-ssa (->Const *int-type* this)))) 680 | 681 | (extend-type java.lang.Integer 682 | SSAWriter 683 | (write-ssa [this] 684 | (write-ssa (->Const *int-type* this)))) 685 | 686 | (extend-type java.lang.Double 687 | SSAWriter 688 | (write-ssa [this] 689 | (write-ssa (->Const *float-type* this)))) 690 | 691 | (extend-type java.lang.Boolean 692 | SSAWriter 693 | (write-ssa [this] 694 | (write-ssa (->Const Int1 (when this 0 1))))) 695 | 696 | (extend-type datomic.db.DbId 697 | SSAWriter 698 | (write-ssa [this] 699 | (fn [plan] 700 | [this plan])) 701 | IToPlan 702 | (add-to-plan [this] 703 | (fn [plan] 704 | [this plan]))) 705 | 706 | 707 | 708 | 709 | (defn engine [module] 710 | (let [provider (llvm/CreateModuleProviderForExistingModule module) 711 | error (llvm/new-pointer) 712 | engine (llvm/new-pointer)] 713 | (assert provider) 714 | (when-not (= (llvm/CreateJITCompiler engine provider 2 error) 0) 715 | (assert false (.getString error 0 false))) 716 | (llvm/DisposeMessage (llvm/value-at error)) 717 | (assert (llvm/value-at engine)) 718 | engine)) 719 | 720 | (defn java-to-llvm-arg [x] 721 | (cond 722 | (integer? x) (llvm/CreateGenericValueOfInt (llvm/Int64Type) x 0) 723 | :else (assert false "Can't convert value"))) 724 | 725 | (defn get-fn [engine module name] 726 | (let [f (llvm/GetNamedFunction module name) 727 | ftype (*)] 728 | (assert f "Can't find function") 729 | (fn [& args] 730 | (println "Running..." args f) 731 | (let [p (into-array Pointer (map java-to-llvm-arg args)) 732 | ex_res (llvm/RunFunction (llvm/value-at engine) f (count p) p) 733 | ires (llvm/GenericValueToInt ex_res 0)] 734 | (doseq [x p] 735 | (llvm/DisposeGenericValue x)) 736 | (llvm/DisposeGenericValue ex_res) 737 | ires)))) 738 | 739 | 740 | 741 | 742 | 743 | ;; compilation 744 | 745 | (defn temp-file [prefix ext] 746 | (let [file (java.io.File/createTempFile prefix ext)] 747 | (.deleteOnExit file) 748 | (.getCanonicalPath file))) 749 | 750 | (defn dump-module-to-temp-file [module] 751 | (let [file (temp-file "mod_dump" ".bc")] 752 | (llvm/WriteBitcodeToFile module file) 753 | file)) 754 | 755 | 756 | (defn verify [module] 757 | (llvm/VerifyModule module) 758 | module) 759 | 760 | 761 | (defn optimize [module] 762 | (let [pass (llvm/CreatePassManager)] 763 | (llvm/AddDefaultPasses pass) 764 | (llvm/RunPassManager pass module) 765 | (llvm/DisposePassManager pass) 766 | #_(llvm/DumpModule module) 767 | module)) 768 | 769 | (defn dump [module] 770 | (llvm/DumpModule module)) 771 | 772 | (defn write-object-file [module march] 773 | (let [file (dump-module-to-temp-file module) 774 | ofile (temp-file "o_dump" ".o") 775 | cmds ["/usr/local/bin/llc" "-filetype=obj" "-o" ofile file] 776 | cmds (if march (concat cmds ["--march" march]) cmds) 777 | {:keys [out err exit] :as mp} (apply shell/sh cmds)] 778 | (apply shell/sh ["/usr/local/bin/llc" "-filetype=asm" "-o" "foo.s" file]) 779 | (println cmds) 780 | (assert (= exit 0) err) 781 | 782 | ofile)) 783 | 784 | (defn interpret-opt [op] 785 | (cond (vector? op) 786 | (let [res (apply shell/sh op)] 787 | (assert (= 0 (:exit res)) (:err res)) 788 | (string/split (string/trim (:out res)) #"[ \n]")) 789 | :else 790 | [op])) 791 | 792 | (defn link-object-file [module filename march & opts] 793 | (let [tmp (write-object-file module march) 794 | opts (mapcat interpret-opt opts) 795 | cmds (concat ["gcc" tmp] 796 | opts 797 | ["-o" filename "--shared"]) 798 | _ (println cmds) 799 | res (apply shell/sh cmds)] 800 | (assert (= 0 (:exit res)) res) 801 | (:out res))) 802 | 803 | (defn link-exe [obj out] 804 | (let [cmds (concat ["gcc" obj "-o" out "-lc"]) 805 | _ (println cmds) 806 | res (apply shell/sh cmds)] 807 | (assert (= 0 (:exit res)) res) 808 | (:out res))) 809 | 810 | 811 | 812 | (defn compile-as-exe [mod opts] 813 | (let [ofile (write-object-file mod "x86-64") 814 | exe-file (or (:out opts) (temp-file "exe_gen" "out")) 815 | out (link-exe ofile exe-file)] 816 | exe-file)) 817 | 818 | (defn run-exe [file & args] 819 | (apply shell/sh file args)) 820 | 821 | ;;;;;;;;;; Target Machine ;;;;;;;;;;;;;; 822 | 823 | -------------------------------------------------------------------------------- /src/mjolnir/gc.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.gc) 2 | 3 | (defprotocol GC 4 | (build-new [this d module builder fn inst defs]) 5 | (add-globals [this conn])) -------------------------------------------------------------------------------- /src/mjolnir/gc/boehm.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.gc.boehm 2 | (:require [mjolnir.constructors-init :refer [defnf]] 3 | [mjolnir.types :refer :all] 4 | [mjolnir.inference :refer [infer-all]] 5 | [mjolnir.ssa :refer [no-type gen-plan assert-entity update-entity add-all get-plan commit add-to-plan]] 6 | [datomic.api :refer [db q] :as d] 7 | [mjolnir.gc :refer :all] 8 | [mjolnir.llvmc :as llvm] 9 | [mjolnir.llvm-builder :refer [unpack-args build-type]]) 10 | (:alias c mjolnir.constructors) 11 | (:import [com.sun.jna Native Pointer Memory])) 12 | 13 | (c/defn ^{:exact "GC_malloc"} ^:extern GC_malloc [IntT size -> IntT*]) 14 | (c/defn ^{:exact "GC_init"} ^:extern GC_init [-> IntT]) 15 | 16 | (c/defn ^{:exact "___init_GC___"} init_gc [-> IntT] 17 | (GC_init) 18 | 0) 19 | 20 | (defrecord BoehmGC [] 21 | GC 22 | (build-new [this d module builder fn inst defs] 23 | (unpack-args defs inst 24 | [size] 25 | (let [fnc (llvm/GetNamedFunction module "GC_malloc") 26 | _ (assert fnc "Couldn't find GC_malloc") 27 | cresult (llvm/BuildCall builder 28 | fnc 29 | (into-array Pointer [size]) 30 | 1 31 | (str "gc_malloc_" (:db/id inst)))] 32 | (llvm/BuildBitCast builder 33 | cresult 34 | (build-type (:node/return-type inst)) 35 | (str "gc_casted_" (:db/id inst)))))) 36 | (add-globals [this conn] 37 | (-> (gen-plan 38 | [_ (add-to-plan (c/module '[mjolnir.gc.boehm]))] 39 | nil) 40 | (get-plan conn) 41 | commit) 42 | conn)) 43 | 44 | (defn convert-to-gc-call [ent] 45 | (let [prev-node (:db/id (first (:inst/_next ent))) 46 | this-id (:db/id ent)] 47 | (gen-plan 48 | [no-type-id (no-type) 49 | gbl-id (assert-entity {:node/type :node.type/inst 50 | :inst/type :inst.type/gbl 51 | :inst.gbl/name "GC_malloc" 52 | :inst/next this-id 53 | :node/return-type no-type-id}) 54 | _ (update-entity this-id {:inst/type :inst.type/call 55 | :inst.call/fn gbl-id}) 56 | _ (update-entity prev-node {:inst/next gbl-id})] 57 | nil))) 58 | 59 | (defn run-gc-pass [conn] 60 | (let [db-val (db conn) 61 | news (q '[:find ?id 62 | :where 63 | [?id :inst/type :inst.type/new]] 64 | db-val)] 65 | (-> (gen-plan 66 | [_ (add-all (->> news 67 | (map (comp (partial d/entity db-val) first)) 68 | (map convert-to-gc-call)))] 69 | nil) 70 | (get-plan conn) 71 | commit) 72 | (infer-all conn) 73 | conn)) 74 | 75 | 76 | -------------------------------------------------------------------------------- /src/mjolnir/inference.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.inference 2 | (:refer-clojure :exclude [==]) 3 | (:require [mjolnir.ssa :as ssa] 4 | [mjolnir.ssa-rules :refer [rules]] 5 | [datomic.api :refer [q db] :as d] 6 | [clojure.core.logic :refer :all] 7 | [clojure.core.logic.datomic :as ld])) 8 | 9 | (defn get-inferences [db] 10 | {:pre [db]} 11 | (let [notype (ffirst (q '[:find ?id 12 | :where 13 | [?id :node/type :node.type/unknown]] 14 | db))] 15 | (assert notype (pr-str "Can't find unknown type" 16 | (q '[:find ?tp 17 | :where 18 | [_ :node/type ?tp]] 19 | db))) 20 | (concat (q '[:find ?id ?attr ?val 21 | :in $ % ?notype 22 | :where 23 | (infer-node ?id ?attr ?val)] 24 | db 25 | @rules 26 | notype) 27 | #_(q '[:find ?id ?attr ?val 28 | :in $ % ?notype 29 | :where 30 | #_[?id :node/return-type ?notype] 31 | (infer-cast-node ?id ?attr ?val)] 32 | db 33 | @rules 34 | notype) 35 | #_(q '[:find ?id ?attr ?val 36 | :in $ % ?notype 37 | :where 38 | #_[?id :node/return-type ?notype] 39 | (infer-binop-node ?id ?attr ?val)] 40 | db 41 | @rules 42 | notype) 43 | #_(->> (q '[:find ?id ?val 44 | :in $ % 45 | :where 46 | [?id :node/return-type ?notype] 47 | (infer-phi-return-type ?id ?val)] 48 | db 49 | @rules) 50 | (map 51 | (fn [[id val]] 52 | [id :node/return-type val])))))) 53 | 54 | (defn infer-all [conn] 55 | (let [db-val (db conn) 56 | nodes (->> (get-inferences (db conn)) 57 | (remove (fn [[id attr val]] 58 | (= val (attr (d/entity db-val id)))))) 59 | data (map (fn [[id attr val]] 60 | [:db/add id attr val]) 61 | nodes)] 62 | @(d/transact conn data) 63 | (let [db-val (db conn) 64 | remaining (concat (q '[:find ?id ?attr 65 | :where 66 | [?id :node/return-type ?tp] 67 | [?tp :node/type :node.type/unknown] 68 | [(identity :node/return-type) ?attr]] 69 | db-val) 70 | (q '[:find ?id ?attr 71 | :where 72 | [?id :inst.cast/type :inst.cast/unknown] 73 | [?id :node/return-type ?tp-to] 74 | [?tp-to :node/type ?data1] 75 | [(identity :inst.cast/type) ?attr]] 76 | db-val))] 77 | (when-not (= 0 (count remaining)) 78 | (println "Remaining nodes...") 79 | (println (pr-str (q '[:find ?nm 80 | :where 81 | [_ :fn/name ?nm]] 82 | db-val))) 83 | (doseq [[id attr] remaining] 84 | (let [ent (d/entity db-val id)] 85 | (println 86 | (pr-str 87 | [(:inst/type ent) 88 | attr 89 | (:node/type (:node/return-type ent)) 90 | (:node/type (:node/return-type (:inst.arg/arg0 ent))) 91 | (:inst/type (:inst.arg/arg0 ent)) 92 | (:inst.gbl/name (:inst.arg/arg0 ent)) 93 | (-> ent 94 | :inst/block 95 | :block/fn 96 | :fn/name) 97 | (-> ent 98 | :inst/block 99 | :block/fn)])))) 100 | (assert false "inference fails"))))) 101 | -------------------------------------------------------------------------------- /src/mjolnir/intrinsics.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.intrinsics 2 | (:require [mjolnir.expressions :as expr] 3 | [mjolnir.types :refer :all] 4 | [mjolnir.constructors-init :as const]) 5 | (:alias c mjolnir.constructors)) 6 | 7 | 8 | (c/defn ^{:exact "llvm.sqrt.f64"} ^:extern llvm-sqrt-f64 [Float64 x -> Float64]) 9 | -------------------------------------------------------------------------------- /src/mjolnir/llvm_builder.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.llvm-builder 2 | (:require [mjolnir.ssa :refer :all] 3 | [mjolnir.ssa-rules :refer [rules]] 4 | [datomic.api :refer [db q] :as d] 5 | [mjolnir.llvmc :as llvm] 6 | [mjolnir.gc :refer [build-new]] 7 | [mjolnir.targets.target :as target] 8 | [mjolnir.config :refer :all]) 9 | (:import [com.sun.jna Native Pointer])) 10 | 11 | (defn- unpack-arg [defs instr idx nm] 12 | `[~nm (~defs (~(idx->arg idx) ~instr))]) 13 | 14 | (defmacro unpack-args [defs instr args & body] 15 | (let [frms (mapcat (fn [idx arg] 16 | (unpack-arg defs instr idx arg)) 17 | (range) 18 | args)] 19 | `(let [~@frms] 20 | ~@(mapcat (fn [idx a] 21 | [`(let [blk# (or (:phi/block (~(idx->arg idx) ~instr)) 22 | (:inst/block (~(idx->arg idx) ~instr))) 23 | blk-inst# (~defs blk#)] 24 | #_(assert blk-inst# (str "Block not built: " blk# " in " (:inst/block ~instr)))) 25 | `(assert ~a 26 | (str "can't find {" (~(idx->arg idx) ~instr) 27 | " " 28 | (:inst/type (~(idx->arg idx) ~instr)) 29 | " " 30 | "} for { " 31 | (:inst/type ~instr) 32 | " " 33 | (:db/id (:inst/block ~instr)) 34 | "} " 35 | (:db/id (:phi/block (~(idx->arg idx) ~instr))))) 36 | `(assert (not (map? ~a)) 37 | (str "bad arg format " (~(idx->arg idx) ~instr) 38 | " " 39 | (:inst/type (~(idx->arg idx) ~instr)) 40 | " " 41 | (:db/id (:inst/block ~instr)) 42 | "-> " 43 | ~(pr-str a) 44 | ~a))]) 45 | (range) 46 | args) 47 | (assoc 48 | ~defs 49 | ~instr 50 | (do ~@body))))) 51 | 52 | (comment 53 | (unpack-args defs instr 54 | [lh rh] 55 | ) 56 | 57 | ) 58 | 59 | ;; Converts a type entity to a llvm type 60 | (defmulti build-type :node/type) 61 | 62 | (defmulti build-instruction (fn [d module builder fn inst defs] 63 | (:inst/type inst))) 64 | 65 | (defmulti build-terminator (fn [module builder fn inst defs] 66 | (:inst/type inst))) 67 | 68 | 69 | (defmethod build-type :default 70 | [x] 71 | (assert false (str "Don't know how to build-type from " (pr-str x)))) 72 | 73 | 74 | ;; Using the type entity (tp) encodes vall as that type 75 | (defmulti encode-const (fn [tp val] 76 | (:node/type tp))) 77 | 78 | 79 | (defmethod build-type :type/int 80 | [x] 81 | (llvm/IntType (:type/width x))) 82 | 83 | (defmethod encode-const :type/int 84 | [tp val] 85 | (llvm/ConstInt (build-type tp) val)) 86 | 87 | (defmethod build-type :type/void 88 | [x] 89 | (llvm/VoidType)) 90 | 91 | (defmethod encode-const :type/pointer 92 | [tp val] 93 | (llvm/ConstNull (build-type tp))) 94 | 95 | 96 | (defmethod build-type :type/float 97 | [x] 98 | (case (:type/width x) 99 | 32 (llvm/FloatType) 100 | 64 (llvm/DoubleType))) 101 | 102 | (defmethod build-type :type/array 103 | [x] 104 | (let [etype (build-type (:type/element-type x))] 105 | (llvm/ArrayType etype (:type/length x)))) 106 | 107 | (defmethod build-type :type/pointer 108 | [x] 109 | (let [etype (build-type (:type/element-type x))] 110 | (llvm/PointerType etype 111 | 0))) 112 | 113 | 114 | (defmethod build-type :type/struct 115 | [x] 116 | (let [members (->> (:type.member/_struct x) 117 | (sort-by :type.member/idx) 118 | (map :type.member/type))] 119 | (llvm/StructType (llvm/map-parr build-type members) 120 | (count members) 121 | false))) 122 | 123 | 124 | 125 | (defmethod encode-const :type/float 126 | [tp val] 127 | (llvm/ConstReal (build-type tp) val)) 128 | 129 | 130 | 131 | 132 | 133 | (defmethod build-type :type/fn 134 | [{return-type :type.fn/return 135 | arg-types :type.fn/arguments 136 | :as this}] 137 | (let [arg-types (to-seq arg-types)] 138 | (llvm/FunctionType (build-type return-type) 139 | (llvm/map-parr build-type arg-types) 140 | (count arg-types) 141 | false))) 142 | 143 | 144 | (defn new-module [] 145 | (llvm/ModuleCreateWithName "Mjolnir Module")) 146 | 147 | (defmulti stub-global (fn [module itm] 148 | (:node/type itm))) 149 | 150 | (defmethod stub-global :node.type/fn 151 | [module {name :fn/name type :fn/type arguments :fn/argument-names linkage :fn/linkage}] 152 | (let [f (llvm/AddFunction module name (build-type type))] 153 | (llvm/SetFunctionCallConv f (target/get-calling-conv *target* 154 | (= :extern 155 | linkage))) 156 | (llvm/SetLinkage f (llvm/kw->linkage :extern)) 157 | f)) 158 | 159 | (defmethod stub-global :node.type/global 160 | [module {name :global/name type :global/type}] 161 | (llvm/AddGlobalInAddressSpace module 162 | (build-type type) 163 | name 164 | (target/default-address-space *target*))) 165 | 166 | (defmulti build-item (fn [db module itm] 167 | (:node/type itm))) 168 | 169 | 170 | (def arg-kws 171 | [:inst.arg/arg0 172 | :inst.arg/arg1 173 | :inst.arg/arg2 174 | :inst.arg/arg3 175 | :inst.arg/arg4 176 | :inst.arg/arg5 177 | :inst.arg/arg6 178 | :inst.arg/arg7 179 | :inst.arg/arg8 180 | :inst.arg/arg9 181 | :inst.arg/arg10 182 | :inst.arg/arg11]) 183 | 184 | 185 | (defn args-seq [ent] 186 | (take-while (complement nil?) (map (partial get ent) arg-kws))) 187 | 188 | 189 | 190 | (defn depends-on? 191 | "Returns true if blk1 requires the results of instructions in blk2" 192 | [blk1 blk2] 193 | (let [st (-> (set (map (fn [x] 194 | (or (:inst/block x) 195 | (:phi/block x))) 196 | (concat (mapcat args-seq (instruction-seq blk1)) 197 | (args-seq (:block/terminator-inst blk1))))) 198 | (disj nil))] 199 | (contains? st blk2))) 200 | 201 | (defn find-a-node [deps already-have-nodes] 202 | (some (fn [[k v]] (if (empty? (remove already-have-nodes v)) k)) deps)) 203 | 204 | (defn order-nodes [deps] 205 | (loop [deps deps already-have-nodes #{} output []] 206 | (if (empty? deps) 207 | output 208 | (if-let [item (find-a-node deps already-have-nodes)] 209 | (recur 210 | (dissoc deps item) 211 | (conj already-have-nodes item) 212 | (conj output item)) 213 | (throw (Exception. "Circular dependency.")))))) 214 | 215 | (defn node-deps [blocks block] 216 | (->> blocks 217 | (remove #{block}) 218 | (filter (partial depends-on? block)))) 219 | 220 | (defn block-comparator [blk1 blk2] 221 | (let [result (cond 222 | (depends-on? blk1 blk2) 1 223 | (depends-on? blk2 blk1) -1 224 | :else 0)] 225 | result)) 226 | 227 | (defn get-unbuilt-deps [block blocks defs] 228 | (when-let [dep-blk (->> 229 | blocks 230 | (remove defs) 231 | (filter (partial depends-on? block blocks)) 232 | first)] 233 | (get-unbuilt-deps dep-blk) 234 | block)) 235 | 236 | #_(defn get-block-deps [fnc] 237 | (let [deps (q '[:find (distinct ?block-b) 238 | :with ?block-a 239 | :where 240 | ])])) 241 | 242 | (defn get-ordered-block-list 243 | "Gets a list of blocks for a function sorted by suggested build order" 244 | [fnc] 245 | (let [entry (:fn/entry-block fnc) 246 | blocks (:block/_fn fnc) 247 | deps (zipmap blocks 248 | (map (partial node-deps blocks) blocks))] 249 | (->> #_(sort block-comparator (:block/_fn fnc)) 250 | #_(block-order (first blocks) #{} (set blocks)) 251 | (order-nodes deps) 252 | (remove #{entry}) 253 | (cons entry)))) 254 | 255 | (defn- build-phi-nodes [blk builder defs] 256 | (reduce 257 | (fn [defs phi] 258 | (assert (:node/return-type phi)) 259 | (assoc defs 260 | phi 261 | (llvm/BuildPhi builder 262 | (build-type (:node/return-type phi)) 263 | (str "phi_" (:db/id phi))))) 264 | defs 265 | (:phi/_block blk))) 266 | 267 | (defn- link-phi-nodes [fnc defs] 268 | (doall (for [block (:block/_fn fnc) 269 | node (:phi/_block block) 270 | incoming (:phi.value/_node node)] 271 | (let [inst (:phi.value/value incoming) 272 | inst-block (:phi.value/block incoming) 273 | llvm-block (defs inst-block) 274 | llvm-inst (defs inst) 275 | llvm-phi (defs node)] 276 | (assert llvm-phi) 277 | (assert llvm-inst) 278 | (assert llvm-block inst-block) 279 | (llvm/AddIncoming llvm-phi 280 | (llvm/map-parr identity [llvm-inst]) 281 | (llvm/map-parr identity [llvm-block]) 282 | 1))))) 283 | 284 | 285 | (defn build-block [db-val module fnc block defs] 286 | (let [builder (llvm/CreateBuilder) 287 | llvm-block (llvm/AppendBasicBlock fnc (str (:block/name block) "_" (:db/id block))) 288 | _ (llvm/PositionBuilderAtEnd builder llvm-block) 289 | defs (assoc defs block llvm-block) 290 | defs (build-phi-nodes block builder defs) 291 | defs (reduce 292 | (fn [defs inst] 293 | (build-instruction db-val module builder fnc inst defs)) 294 | defs 295 | (instruction-seq block))] 296 | defs)) 297 | 298 | (defn build-termination [db-val module fnc block defs] 299 | (let [instr (:block/terminator-inst block) 300 | llvm-block (defs block) 301 | builder (llvm/CreateBuilder)] 302 | (assert (and instr llvm-block) 303 | (str "Looking for " 304 | (:db/id (:block/terminator-inst block)) 305 | " and " 306 | (:db/id block))) 307 | (llvm/PositionBuilderAtEnd builder llvm-block) 308 | (build-instruction db-val module builder fnc instr defs))) 309 | 310 | (defmethod build-item :node.type/fn 311 | [db-val module this] 312 | (when-not (:fn/extern? this) 313 | (let [blocks (get-ordered-block-list this) 314 | fnc (llvm/GetNamedFunction module (:fn/name this)) 315 | defs (reduce 316 | (fn [defs block] 317 | (build-block db-val module fnc block defs)) 318 | {} 319 | blocks) 320 | defs (reduce 321 | (fn [defs block] 322 | (build-termination db-val module fnc block defs)) 323 | defs 324 | blocks)] 325 | (link-phi-nodes this defs)))) 326 | 327 | (defmethod build-item :node.type/global 328 | [db-val module {name :global/name type :global/type :as this}] 329 | (when-not (:global/extern? this) 330 | (let [gbl (llvm/GetNamedGlobal module name)] 331 | (assert gbl (str "Can't find Global " (pr-str name))) 332 | (llvm/SetInitializer gbl (encode-const type 333 | (or (:const/int-value this) 334 | (:const/float-value this)))) 335 | gbl))) 336 | 337 | 338 | (defmethod build-instruction :default 339 | [d module builder fn itm defs] 340 | (assert false (pr-str "Can't build instruction " (d/touch itm)))) 341 | 342 | (defmethod build-instruction :inst.type/const 343 | [d module builder fn itm defs] 344 | (assoc defs itm (encode-const (:const/type itm) 345 | (or (:const/int-value itm) 346 | (:const/float-value itm))))) 347 | 348 | 349 | 350 | (defmethod build-instruction :inst.type/arg 351 | [d module builder fn inst defs] 352 | (assoc defs inst 353 | (llvm/GetParam fn (:inst.arg/idx inst)))) 354 | 355 | (defn- gen-op-name [instr] 356 | (name (gensym (str (name (:inst.binop/type instr)) "_")))) 357 | 358 | (def binop-map 359 | {:type/int 360 | {:inst.binop.type/add :inst.binop.subtype/iadd 361 | :inst.binop.type/sub :inst.binop.subtype/isub 362 | :inst.binop.type/mul :inst.binop.subtype/imul 363 | :inst.binop.type/div :inst.binop.subtype/idiv 364 | :inst.binop.type/mod :inst.binop.subtype/imod 365 | :inst.binop.type/and :inst.binop.subtype/and 366 | :inst.binop.type/or :inst.binop/subtype/or} 367 | :type/float 368 | {:inst.binop.type/add :inst.binop.subtype/fadd 369 | :inst.binop.type/sub :inst.binop.subtype/fsub 370 | :inst.binop.type/mul :inst.binop.subtype/fmul 371 | :inst.binop.type/div :inst.binop.subtype/fdiv 372 | :inst.binop.type/rem :inst.binop.subtype/frem}}) 373 | 374 | (def binop->llvm-binop 375 | {:inst.binop.subtype/iadd llvm/LLVMAdd 376 | :inst.binop.subtype/isub llvm/LLVMSub 377 | :inst.binop.subtype/imul llvm/LLVMMul 378 | :inst.binop.subtype/idiv llvm/LLVMSDiv 379 | :inst.binop.subtype/imod llvm/LLVMSRem 380 | :inst.binop.subtype/fadd llvm/LLVMFAdd 381 | :inst.binop.subtype/fsub llvm/LLVMFSub 382 | :inst.binop.subtype/fmul llvm/LLVMFMul 383 | :inst.binop.subtype/fdiv llvm/LLVMFDiv 384 | :inst.binop.subtype/fmod llvm/LLVMFRem 385 | :inst.binop.subtype/and llvm/LLVMAnd 386 | :inst.binop.subtype/or llvm/LLVMOr}) 387 | 388 | (defmethod build-instruction :inst.type/binop 389 | [d module builder fn inst defs] 390 | (let [llvm-op (-> inst 391 | :node/return-type 392 | :node/type 393 | binop-map 394 | (get (:inst.binop/type inst)) 395 | binop->llvm-binop)] 396 | (assert llvm-op (str "no binop map for: " 397 | (:inst.binop/sub-type inst) 398 | " " 399 | (:inst.binop/type inst))) 400 | (unpack-args defs inst 401 | [lh rh] 402 | (llvm/BuildBinOp builder llvm-op lh rh (gen-op-name inst))))) 403 | 404 | (defmethod build-instruction :inst.type/jmp 405 | [d module builder fn inst defs] 406 | (unpack-args defs inst 407 | [dest] 408 | (llvm/BuildBr builder dest))) 409 | 410 | (defmethod build-instruction :inst.type/sizeof 411 | [d module builder fn inst defs] 412 | (assoc defs inst 413 | (llvm/SizeOf (build-type (:inst.sizeof/type inst))))) 414 | 415 | (defmethod build-instruction :inst.type/br 416 | [d module builder fn inst defs] 417 | (unpack-args defs inst 418 | [test then else] 419 | (llvm/BuildCondBr builder test then else))) 420 | 421 | 422 | (def cmp-map 423 | {[:type/int :type/int :inst.cmp.pred/=] :inst.cmp.sub-pred/int-eq 424 | [:type/int :type/int :inst.cmp.pred/not=] :inst.cmp.sub-pred/int-ne 425 | [:type/int :type/int :inst.cmp.pred/>] :inst.cmp.sub-pred/int-sgt 426 | [:type/int :type/int :inst.cmp.pred/<] :inst.cmp.sub-pred/int-slt 427 | [:type/int :type/int :inst.cmp.pred/<=] :inst.cmp.sub-pred/int-sle 428 | [:type/int :type/int :inst.cmp.pred/>=] :inst.cmp.sub-pred/int-sge 429 | 430 | [:type/float :type/float :inst.cmp.pred/=] :inst.cmp.sub-pred/real-oeq 431 | [:type/float :type/float :inst.cmp.pred/not=] :inst.cmp.sub-pred/real-one 432 | [:type/float :type/float :inst.cmp.pred/>] :inst.cmp.sub-pred/real-ogt 433 | [:type/float :type/float :inst.cmp.pred/<] :inst.cmp.sub-pred/real-olt 434 | [:type/float :type/float :inst.cmp.pred/<=] :inst.cmp.sub-pred/real-ole 435 | [:type/float :type/float :inst.cmp.pred/>=] :inst.cmp.sub-pred/real-oge}) 436 | 437 | (def cmp-table 438 | {:inst.cmp.sub-pred/int-eq llvm/LLVMIntEQ 439 | :inst.cmp.sub-pred/int-ne llvm/LLVMIntNE 440 | :inst.cmp.sub-pred/int-ugt llvm/LLVMIntUGT 441 | :inst.cmp.sub-pred/int-uge llvm/LLVMIntUGE 442 | :inst.cmp.sub-pred/int-ult llvm/LLVMIntULT 443 | :inst.cmp.sub-pred/int-ule llvm/LLVMIntULE 444 | :inst.cmp.sub-pred/int-sgt llvm/LLVMIntSGT 445 | :inst.cmp.sub-pred/int-sge llvm/LLVMIntSGE 446 | :inst.cmp.sub-pred/int-slt llvm/LLVMIntSLT 447 | :inst.cmp.sub-pred/int-sle llvm/LLVMIntSLE 448 | 449 | :inst.cmp.sub-pred/real-predicate-false llvm/LLVMRealPredicateFalse 450 | :inst.cmp.sub-pred/real-oeq llvm/LLVMRealOEQ 451 | :inst.cmp.sub-pred/real-ogt llvm/LLVMRealOGT 452 | :inst.cmp.sub-pred/real-oge llvm/LLVMRealOGE 453 | :inst.cmp.sub-pred/real-ole llvm/LLVMRealOLE 454 | :inst.cmp.sub-pred/real-olt llvm/LLVMRealOLT 455 | :inst.cmp.sub-pred/real-one llvm/LLVMRealONE 456 | :inst.cmp.sub-pred/real-ord llvm/LLVMRealORD 457 | :inst.cmp.sub-pred/real-uno llvm/LLVMRealUNO 458 | :inst.cmp.sub-pred/real-ueq llvm/LLVMRealUEQ 459 | :inst.cmp.sub-pred/real-ugt llvm/LLVMRealUGT 460 | :inst.cmp.sub-pred/real-uge llvm/LLVMRealUGE 461 | :inst.cmp.sub-pred/real-ult llvm/LLVMRealULT 462 | :inst.cmp.sub-pred/real-ule llvm/LLVMRealULE 463 | :inst.cmp.sub-pred/real-une llvm/LLVMRealUNE 464 | :inst.cmp.sub-pred/real-predicate-true llvm/LLVMRealOEQ}) 465 | 466 | (defmethod build-instruction :inst.type/cmp 467 | [d module builder fn inst defs] 468 | (unpack-args defs inst 469 | [lh rh] 470 | (assert (= (-> inst :inst.arg/arg0 :node/return-type) 471 | (-> inst :inst.arg/arg1 :node/return-type))) 472 | (let [lh-t (-> inst :inst.arg/arg0 :node/return-type :node/type) 473 | rh-t (-> inst :inst.arg/arg1 :node/return-type :node/type) 474 | pred (-> inst :inst.cmp/pred) 475 | sub-type (-> (cmp-map [lh-t rh-t pred]) 476 | cmp-table)] 477 | (assert (integer? sub-type) (pr-str "Invalid cmp type" [sub-type 478 | lh-t 479 | rh-t 480 | pred 481 | (cmp-map [lh-t rh-t pred]) 482 | (-> (cmp-map [lh-t rh-t pred]) 483 | cmp-table)])) 484 | (cond 485 | (= lh-t rh-t :type/int) 486 | (llvm/BuildICmp builder sub-type lh rh (str "icmp_" (:db/id inst))) 487 | 488 | (= lh-t rh-t :type/float) 489 | (llvm/BuildFCmp builder sub-type lh rh (str "fcmp_" (:db/id inst))) 490 | 491 | :else (assert false "No LLVM predicate builder"))))) 492 | 493 | (defmethod build-instruction :inst.type/return-val 494 | [d module builder fn inst defs] 495 | (unpack-args defs inst 496 | [ret] 497 | (llvm/BuildRet builder 498 | ret 499 | (str "return_" (:db/id inst))))) 500 | 501 | (defmethod build-instruction :inst.type/gbl 502 | [d module builder fn itm defs] 503 | (assert defs) 504 | (assoc defs 505 | itm 506 | (or (llvm/GetNamedFunction module (:inst.gbl/name itm)) 507 | (llvm/GetNamedGlobal module (:inst.gbl/name itm))))) 508 | 509 | (defmethod build-instruction :inst.type/jmp 510 | [d module builder fn inst defs] 511 | (unpack-args defs inst 512 | [blk] 513 | (llvm/BuildBr builder blk))) 514 | 515 | (defmethod build-instruction :inst.type/call 516 | [d module builder fn inst defs] 517 | (let [args (map defs (args-seq inst)) 518 | fnc (defs (:inst.call/fn inst)) 519 | is-void? (-> inst 520 | :inst.call/fn 521 | :node/return-type 522 | :node/type 523 | (= :type/void))] 524 | (assert (and (every? identity args) fnc)) 525 | (assert (= (llvm/CountParams fnc) 526 | (count args)) 527 | (str "Arg Count mismatch: " 528 | (-> inst :inst.call/fn :inst.gbl/name) 529 | " " 530 | (llvm/CountParams fnc) 531 | " called with " 532 | (count args))) 533 | (->> 534 | (llvm/BuildCall builder fnc (llvm/map-parr identity args) (count args) (when-not is-void? 535 | (str (:db/id inst)))) 536 | (assoc defs inst)))) 537 | 538 | (def atomic-mappings 539 | {:cas llvm/LLVMAtomicRMWBinOpXchg 540 | :+ llvm/LLVMAtomicRMWBinOpAdd 541 | :- llvm/LLVMAtomicRMWBinOpSub 542 | :and llvm/LLVMAtomicRMWBinOpAnd 543 | :nand llvm/LLVMAtomicRMWBinOpNand 544 | :or llvm/LLVMAtomicRMWBinOpOr 545 | :xor llvm/LLVMAtomicRMWBinOpXor 546 | :max llvm/LLVMAtomicRMWBinOpMax 547 | :min llvm/LLVMAtomicRMWBinOpMin 548 | :umax llvm/LLVMAtomicRMWBinOpUMax 549 | :umin llvm/LLVMAtomicRMWBinOpUMin}) 550 | 551 | (defmethod build-instruction :inst.type/atomic 552 | [d module builder fn inst defs] 553 | (unpack-args defs inst 554 | [ptr val] 555 | (let [mapping (atomic-mappings (:inst.atomic/op inst))] 556 | (assert mapping (str "Invalid Atomic Operation " (:inst.atomic/op inst))) 557 | (llvm/BuildAtomicRMW builder 558 | mapping 559 | ptr 560 | val 561 | llvm/LLVMAtomicOrderingSequentiallyConsistent 562 | false)))) 563 | 564 | (defmethod build-instruction :inst.type/callp 565 | [d module builder fn inst defs] 566 | (let [args (map defs (args-seq inst)) 567 | fnc (defs (:inst.callp/fn inst))] 568 | (assert (and (every? identity args) fnc)) 569 | (->> 570 | (llvm/BuildCall builder fnc (llvm/map-parr identity args) (count args) (str (:db/id inst))) 571 | (assoc defs inst)))) 572 | 573 | 574 | (defmethod build-instruction :inst.type/malloc 575 | [d module builder fn inst defs] 576 | (let [tp (:inst.malloc/type inst) 577 | llvm-type (build-type tp)] 578 | (->> (llvm/BuildMalloc builder llvm-type (str "malloc_" (:db/id inst))) 579 | (assoc defs inst)))) 580 | 581 | (defmethod build-instruction :inst.type/new 582 | [d module builder fn inst defs] 583 | (build-new *gc* d module builder fn inst defs)) 584 | 585 | (defmethod build-instruction :inst.type/free 586 | [d module builder fn inst defs] 587 | (unpack-args defs inst 588 | [ptr] 589 | (llvm/BuildFree builder ptr))) 590 | 591 | (defn- pointer-type-to [x] 592 | {:node/type :type/pointer 593 | :type/element-type x}) 594 | 595 | 596 | (defmethod build-instruction :inst.type/aset 597 | [d module builder fn inst defs] 598 | (unpack-args defs inst 599 | [ptr idx val] 600 | (let [ret-type (-> inst 601 | :inst.arg/arg0 602 | :node/return-type 603 | :type/element-type 604 | pointer-type-to 605 | build-type) 606 | casted (llvm/BuildBitCast builder ptr ret-type (str "casted_" (:db/id inst))) 607 | gep (llvm/BuildGEP builder 608 | casted 609 | (into-array Pointer [idx]) 610 | 1 611 | (str "gep_" (:db/id inst)))] 612 | (llvm/BuildStore builder val gep) 613 | gep))) 614 | 615 | (defmethod build-instruction :inst.type/store 616 | [d module builder fn inst defs] 617 | (unpack-args defs inst 618 | [ptr val] 619 | (let [ret-type (-> inst 620 | :inst.arg/arg0 621 | :node/return-type 622 | :type/element-type 623 | pointer-type-to 624 | build-type) 625 | casted (llvm/BuildBitCast builder ptr ret-type (str "casted_" (:db/id inst))) 626 | gep (llvm/BuildGEP builder 627 | casted 628 | (into-array Pointer [0]) 629 | 1 630 | (str "gep_" (:db/id inst)))] 631 | (llvm/BuildStore builder val gep) 632 | gep))) 633 | 634 | 635 | 636 | (defmethod build-instruction :inst.type/aget 637 | [d module builder fn inst defs] 638 | (unpack-args defs inst 639 | [ptr idx] 640 | (let [ptr-type (-> inst 641 | :inst.arg/arg0 642 | :node/return-type 643 | :type/element-type 644 | pointer-type-to 645 | build-type) 646 | casted (llvm/BuildBitCast builder ptr ptr-type (str "casted_" (:db/id inst))) 647 | gep (llvm/BuildGEP builder 648 | casted 649 | (into-array Pointer [idx]) 650 | 1 651 | (str "gep_" (:db/id inst)))] 652 | (llvm/BuildLoad builder gep (str "load_" (:db/id inst)))))) 653 | 654 | (defmethod build-instruction :inst.type/nth 655 | [d module builder fn inst defs] 656 | (unpack-args defs inst 657 | [ptr idx] 658 | (let [ptr-type (-> inst 659 | :inst.arg/arg0 660 | :node/return-type 661 | :type/element-type 662 | pointer-type-to 663 | build-type) 664 | casted (llvm/BuildBitCast builder ptr ptr-type (str "casted_" (:db/id inst))) 665 | gep (llvm/BuildGEP builder 666 | casted 667 | (into-array Pointer [idx]) 668 | 1 669 | (str "gep_" (:db/id inst)))] 670 | gep))) 671 | 672 | (def cast-table 673 | {:inst.cast.type/fp-to-si llvm/LLVMFPToSI 674 | :inst.cast.type/si-to-fp llvm/LLVMSIToFP 675 | :inst.cast.type/trunc llvm/LLVMTrunc 676 | :inst.cast.type/zext llvm/LLVMZExt 677 | :inst.cast.type/bitcast llvm/LLVMBitcast 678 | :inst.cast.type/ptr-to-int llvm/LLVMPtrToInt 679 | :inst.cast.type/int-to-ptr llvm/LLVMIntToPtr}) 680 | 681 | (defmethod build-instruction :inst.type/cast 682 | [d module builder fn inst defs] 683 | (unpack-args defs inst 684 | [val] 685 | (let [to-type (-> inst 686 | :node/return-type 687 | build-type) 688 | sub-type (cast-table (:inst.cast/type inst))] 689 | (assert sub-type (str "Unknown subtype for " (d/touch inst) (d/touch (:node/return-type inst)) (:inst.cast/type inst) to-type)) 690 | (llvm/BuildCast builder sub-type val to-type (str "cast_" (:db/id inst)))))) 691 | 692 | (defn pointer-to [x] 693 | {:node/type :type/pointer 694 | :type/element-type x}) 695 | 696 | #_(defn cast-struct [ptr tp] 697 | {:inst.type/cast 698 | :node/return-type 699 | :inst.cast/type :inst.cast.type/bitcast 700 | :inst.arg/arg0 ptr}) 701 | 702 | (defmethod build-instruction :inst.type/set 703 | [d module builder fnc inst defs] 704 | (unpack-args defs inst 705 | [ptr val] 706 | (let [return-type (-> inst 707 | :node/return-type 708 | :type/element-type) 709 | filtered (keep (fn [member] 710 | (when (= (:type.member/name member) 711 | (:inst.set/member inst)) 712 | (:type.member/idx member))) 713 | (-> return-type 714 | :type.member/_struct)) 715 | idx (first filtered) 716 | _ (assert (integer? idx) (str (d/touch idx))) 717 | _ (assert idx (str "Member not found" 718 | (:inst.set/member inst) 719 | (vec (:type.member/_struct return-type)))) 720 | _ (assert (= 1 (count filtered)) (str "Duplicate member name" (vec filtered))) 721 | casted (llvm/BuildCast builder 722 | llvm/LLVMBitcast 723 | ptr 724 | (build-type (pointer-to return-type)) 725 | (str "casted_" (:db/id inst))) 726 | gep (llvm/BuildStructGEP builder casted idx (str "gep_" (:db/id inst)))] 727 | (llvm/BuildStore builder val gep) 728 | ptr))) 729 | 730 | 731 | (defmethod build-instruction :inst.type/get 732 | [d module builder fnc inst defs] 733 | (unpack-args defs inst 734 | [ptr] 735 | (let [return-type (-> inst 736 | :inst.arg/arg0 737 | :node/return-type 738 | :type/element-type) 739 | filtered (keep (fn [member] 740 | (when (= (:type.member/name member) 741 | (:inst.get/member inst)) 742 | (:type.member/idx member))) 743 | (-> return-type 744 | :type.member/_struct)) 745 | idx (first filtered) 746 | _ (assert idx (str "Member not found" 747 | (:inst.get/member inst) 748 | (d/touch return-type) 749 | (vec (:type.member/_struct return-type)))) 750 | _ (assert (integer? idx) (str (d/touch idx))) 751 | _ (assert (= 1 (count filtered)) (str "Duplicate member name" (vec filtered))) 752 | casted (llvm/BuildCast builder 753 | llvm/LLVMBitcast 754 | ptr 755 | (build-type (pointer-to return-type)) 756 | (str "casted_" (:db/id inst))) 757 | gep (llvm/BuildStructGEP builder casted idx (str "gep_" (:db/id inst)))] 758 | (llvm/BuildLoad builder gep (str "get_"(:db/id inst)))))) 759 | 760 | (defn build [db] 761 | (let [globals (->> (q '[:find ?id 762 | :in $ % 763 | :where 764 | (global-def ?id ?name ?type)] 765 | db 766 | @rules) 767 | (map (comp (partial d/entity db) first))) 768 | module (new-module) 769 | builder (llvm/CreateBuilder)] 770 | (doseq [global globals] 771 | (stub-global module global)) 772 | (doseq [global globals] 773 | (build-item db module global)) 774 | module)) 775 | 776 | 777 | (defn verify [module] 778 | (let [ptr (llvm/new-pointer)] 779 | (when-not (= (llvm/VerifyModule module llvm/LLVMPrintMessageAction ptr) false) 780 | (assert false #_(.getString ptr 0))) 781 | (llvm/DisposeMessage (llvm/value-at ptr)) 782 | module)) 783 | 784 | 785 | (defn optimize [module] 786 | (let [pass (llvm/CreatePassManager)] 787 | (llvm/AddDefaultPasses pass) 788 | (llvm/RunPassManager pass module) 789 | (llvm/DisposePassManager pass) 790 | #_(llvm/DumpModule module) 791 | module)) 792 | 793 | (defn dump [module] 794 | (llvm/DumpModule module)) 795 | 796 | -------------------------------------------------------------------------------- /src/mjolnir/llvmc.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.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.4svn) 7 | 8 | (def strip-chars 4) 9 | 10 | (defn get-function [s] 11 | `(com.sun.jna.Function/getFunction ~(name *lib*) ~(name s))) 12 | 13 | (defn debug [s] 14 | (println s) 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 (apply str (drop strip-chars (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 | (defnative Integer LLVMBuildRetVoid) 93 | 94 | (defnative Integer LLVMLinkInJIT) 95 | (defnative Integer LLVMLinkInInterpreter) 96 | (defnative Integer LLVMInitializeX86Target) 97 | (defnative Integer LLVMInitializeX86TargetInfo) 98 | (defnative Integer LLVMInitializeX86TargetMC) 99 | (defnative Pointer LLVMRunFunction) 100 | (defnative Boolean LLVMFindFunction) 101 | (defnative Pointer LLVMCreateGenericValueOfInt) 102 | (defnative Integer LLVMGenericValueToInt) 103 | (defnative Pointer LLVMBuildAdd) 104 | (defnative Pointer LLVMBuildSub) 105 | (defnative Pointer LLVMConstInt) 106 | (defnative Pointer LLVMConstReal) 107 | (defnative Pointer LLVMBuildICmp) 108 | (defnative Pointer LLVMBuildFCmp) 109 | (defnative Pointer LLVMIntType) 110 | (defnative Pointer LLVMVoidType) 111 | 112 | (defnative Pointer LLVMBuildCondBr) 113 | (defnative Pointer LLVMBuildPhi) 114 | (defnative Integer LLVMAddIncoming) 115 | (defnative Pointer LLVMTypeOf) 116 | (defnative Integer LLVMCountParamTypes) 117 | (defnative Integer LLVMGetTypeKind) 118 | (defnative Integer LLVMDisposeGenericValue) 119 | (defnative Integer LLVMDisposeBuilder) 120 | (defnative Pointer LLVMBuildBr) 121 | (defnative Pointer LLVMBuildCall) 122 | (defnative Pointer LLVMBuildAlloca) 123 | (defnative Pointer LLVMBuildFree) 124 | (defnative Pointer LLVMBuildLoad) 125 | (defnative Pointer LLVMBuildStore) 126 | (defnative Pointer LLVMBuildArrayMalloc) 127 | (defnative Pointer LLVMBuildGEP) 128 | (defnative Pointer LLVMBuildBitCast) 129 | (defnative Pointer LLVMBuildCast) 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 LLVMVectorType) 141 | (defnative Pointer LLVMDumpValue) 142 | (defnative Integer LLVMGetArrayLength) 143 | (defnative Pointer LLVMGetElementType) 144 | (defnative Pointer LLVMConstArray) 145 | (defnative Pointer LLVMConstString) 146 | (defnative Pointer LLVMConstStruct) 147 | (defnative Pointer LLVMConstGEP) 148 | (defnative Pointer LLVMConstVector) 149 | (defnative Pointer LLVMConstBitCast) 150 | (defnative Integer LLVMCountParams) 151 | (defnative Pointer LLVMAddGlobal) 152 | (defnative Pointer LLVMAddGlobalInAddressSpace) 153 | (defnative Integer LLVMSetInitializer) 154 | (defnative Integer LLVMWriteBitcodeToFile) 155 | (defnative Pointer LLVMGetNamedGlobal) 156 | (defnative Pointer LLVMGetNamedFunction) 157 | (defnative Pointer LLVMInt8Type) 158 | (defnative Pointer LLVMInt1Type) 159 | (defnative Pointer LLVMFloatType) 160 | (defnative Pointer LLVMDoubleType) 161 | (defnative Pointer LLVMPointerType) 162 | (defnative Integer LLVMSetLinkage) 163 | (defnative Integer LLVMGetIntTypeWidth) 164 | (defnative Pointer LLVMBuildStructGEP) 165 | (defnative Pointer LLVMBuildAdd) 166 | (defnative Pointer LLVMBuildFAdd) 167 | (defnative Pointer LLVMBuildFSub) 168 | (defnative Pointer LLVMBuildMul) 169 | (defnative Pointer LLVMBuildFMul) 170 | (defnative Pointer LLVMBuildFDiv) 171 | (defnative Pointer LLVMBuildSub) 172 | (defnative Pointer LLVMBuildShl) 173 | (defnative Pointer LLVMBuildLShr) 174 | (defnative Pointer LLVMBuildAnd) 175 | (defnative Pointer LLVMBuildNot) 176 | (defnative Pointer LLVMBuildZExt) 177 | (defnative Pointer LLVMBuildTrunc) 178 | (defnative Pointer LLVMBuildFPToSI) 179 | (defnative Pointer LLVMBuildSIToFP) 180 | (defnative Pointer LLVMBuildOr) 181 | (defnative Pointer LLVMBuildMalloc) 182 | (defnative Pointer LLVMSizeOf) 183 | (defnative Pointer LLVMConstNull) 184 | (defnative Pointer LLVMBuildBinOp) 185 | (defnative Pointer LLVMBuildAtomicRMW) 186 | 187 | (defnative Pointer LLVMBuildExtractElement) 188 | (defnative Pointer LLVMBuildInsertElement) 189 | 190 | (defnative Integer LLVMAddConstantPropagationPass) 191 | (defnative Integer LLVMAddInstructionCombiningPass) 192 | (defnative Integer LLVMAddPromoteMemoryToRegisterPass) 193 | (defnative Integer LLVMAddGVNPass) 194 | (defnative Integer LLVMAddCFGSimplificationPass) 195 | (defnative Integer LLVMAddBBVectorizePass) 196 | (defnative Integer LLVMAddLoopVectorizePass) 197 | (defnative Integer LLVMAddLoopUnrollPass) 198 | (defnative Pointer LLVMAddFunctionInliningPass) 199 | 200 | 201 | 202 | (defn AddDefaultPasses [pm] 203 | (doto pm 204 | AddFunctionInliningPass 205 | #_AddLoopUnrollPass 206 | AddConstantPropagationPass 207 | AddInstructionCombiningPass 208 | AddPromoteMemoryToRegisterPass 209 | AddGVNPass 210 | AddCFGSimplificationPass 211 | AddBBVectorizePass 212 | #_AddLoopVectorizePass)) 213 | 214 | 215 | (def ^:dynamic *module* (ModuleCreateWithName "tmp")) 216 | (def ^:dynamic *fn*) 217 | (def ^:dynamic *locals*) 218 | (def ^:dynamic *builder*) 219 | (def ^:dynamic *block*) 220 | 221 | (defn init-target [] 222 | (LinkInJIT) 223 | (LinkInInterpreter) 224 | (InitializeX86TargetInfo) 225 | (InitializeX86Target) 226 | (InitializeX86TargetMC)) 227 | 228 | (init-target) 229 | 230 | 231 | 232 | (defmacro defenum 233 | ([nm defs] 234 | `(defenum ~nm 0 ~defs)) 235 | ([nm init defs] 236 | (list* 'do 237 | `(def ~nm {:idx ~(zipmap (range) 238 | (map (comp keyword name) defs)) 239 | :defs ~(zipmap (map (comp keyword name) defs) 240 | (range init Integer/MAX_VALUE))}) 241 | (map (fn [d idx] 242 | `(def ~d ~idx)) 243 | defs 244 | (range init Integer/MAX_VALUE))))) 245 | 246 | (defenum LLVMTypeKind 247 | [LLVMVoidTypeKind 248 | LLVMHalfTypeKind 249 | LLVMFloatTypeKind 250 | LLVMDoubleTypeKind 251 | LLVMX86_FP80TypeKind 252 | LLVMFP128TypeKind 253 | LLVMPPC_FP128TypeKind 254 | LLVMLabelTypeKind 255 | LLVMIntegerTypeKind 256 | LLVMFunctionTypeKind 257 | LLVMStructTypeKind 258 | LLVMArrayTypeKind 259 | LLVMPointerTypeKind 260 | LLVMVectorTypeKind 261 | LLVMMetadataTypeKind 262 | LLVMX86_MMXTypeKind]) 263 | 264 | (defenum LLVMCodeGentFileType 265 | [LLVMAssemblyFile 266 | LLVMObjectFile]) 267 | 268 | (defenum LLVMRelocMode 269 | [LLVMRelocDefault 270 | LLVMRelocStatic 271 | LLVMRelocPIC 272 | LLVMRelocDynamicNoPIC]) 273 | 274 | (defenum LLVMCodeGenOptLevel 275 | [LLVMCodeGenLevelNone 276 | LLVMCodeGenLevelLess 277 | LLVMCodeGenLevelDefault 278 | LLVMCodeGenLevelAggressive]) 279 | 280 | (defenum LLVMCodeModel 281 | [LLVMCodeModelDefault 282 | LLVMCodeModelJITDefault 283 | LLVMCodeModelSmall 284 | LLVMCodeModelKernel 285 | LLVMCodeModelMedium 286 | LLVMCodeModelLarge]) 287 | 288 | 289 | (defenum LLVMLinkage 290 | [LLVMExternalLinkage, ; Externally visible function 291 | LLVMAvailableExternallyLinkage, 292 | LLVMLinkOnceAnyLinkage, ; Keep one copy of function when linking (inline) 293 | LLVMLinkOnceODRLinkage, ; Same, but only replaced by something equivalent. 294 | LLVMWeakAnyLinkage, ; Keep one copy of function when linking (weak) 295 | LLVMWeakODRLinkage, ; Same, but only replaced by something equivalent. 296 | LLVMAppendingLinkage, ; Special purpose, only applies to global arrays 297 | LLVMInternalLinkage, ; Rename collisions when linking (static functions) 298 | LLVMPrivateLinkage, ; Like Internal, but omit from symbol table 299 | LLVMDLLImportLinkage, ; Function to be imported from DLL 300 | LLVMDLLExportLinkage, ; Function to be accessible from DLL 301 | LLVMExternalWeakLinkage,; ExternalWeak linkage description 302 | LLVMGhostLinkage, ; Obsolete 303 | LLVMCommonLinkage, ; Tentative definitions 304 | LLVMLinkerPrivateLinkage, ; Like Private, but linker removes. 305 | LLVMLinkerPrivateWeakLinkage, ; Like LinkerPrivate, but is weak. 306 | LLVMLinkerPrivateWeakDefAutoLinkage]) ; Like LinkerPrivateWeak, but possibly hidden. 307 | 308 | 309 | (defenum LLVMIntPredicate 310 | 32 311 | [LLVMIntEQ 312 | LLVMIntNE 313 | LLVMIntUGT 314 | LLVMIntUGE 315 | LLVMIntULT 316 | LLVMIntULE 317 | LLVMIntSGT 318 | LLVMIntSGE 319 | LLVMIntSLT 320 | LLVMIntSLE]) 321 | 322 | (defenum LLVMRealPredicate 323 | [LLVMRealPredicateFalse 324 | LLVMRealOEQ 325 | LLVMRealOGT 326 | LLVMRealOGE 327 | LLVMRealOLT 328 | LLVMRealOLE 329 | LLVMRealONE 330 | LLVMRealORD 331 | LLVMRealUNO 332 | LLVMRealUEQ 333 | LLVMRealUGT 334 | LLVMRealUGE 335 | LLVMRealULT 336 | LLVMRealULE 337 | LLVMRealUNE 338 | LLVMRealPredicateTrue]) 339 | 340 | (defenum LLVMOpcode 341 | 1 342 | [;; Terminators Instructions 343 | LLVMRet 344 | LLVMBr 345 | LLVMSwitch 346 | LLVMIndirectBr 347 | LLVMInvoke 348 | _Removed 349 | LLVMUnreachable 350 | 351 | ;; Standard Binary Operators 352 | LLVMAdd 353 | LLVMFAdd 354 | LLVMSub 355 | LLVMFSub 356 | LLVMMul 357 | LLVMFMul 358 | LLVMUDiv 359 | LLVMSDiv 360 | LLVMFDiv 361 | LLVMURem 362 | LLVMSRem 363 | LLVMFRem 364 | ;; Logical operators 365 | LLVMShl 366 | LLVMLShr 367 | LLVMAShr 368 | LLVMAnd 369 | LLVMOr 370 | LLVMXor 371 | ;; Memory Operators 372 | LLVMAlloca 373 | LLVMLoad 374 | LLVMStore 375 | LLVMGetElementPtr 376 | ;; Cast Operators 377 | LLVMTrunc 378 | LLVMZExt 379 | LLVMSExt 380 | LLVMFPToUI 381 | LLVMFPToSI 382 | LLVMUIToFP 383 | LLVMSIToFP 384 | LLVMFPTrunc 385 | LLVMFPExt 386 | LLVMPtrToInt 387 | LLVMIntToPtr 388 | LLVMBitcast 389 | ;; Other 390 | LLVMICmp 391 | LLVMFCmp 392 | LLVMPHI 393 | LLVMCall 394 | LLVMSelect 395 | LLVMUserOp1 396 | LLVMUserOp2 397 | LLVMVAArg 398 | LLVMExtractElement 399 | LLVMInsertElement 400 | LLVMShuffleVector 401 | LLVMExtractValue 402 | LLVMInsertValue 403 | ;; Atomics 404 | LLVMFence 405 | LLVMAtomicCmpXchg 406 | LLVMAtomicRMW 407 | ;; Exception handling 408 | LLVMResume 409 | LLVMLandingPad]) 410 | 411 | (defenum LLVMAtomicOrdering 412 | 0 413 | [LLVMAtomicOrderingNotAtomic 414 | LLVMAtomicOrderingUnordered 415 | LLVMAtomicOrderingMonotonic 416 | __ ;; No ID 3 enum 417 | LLVMAtomicOrderingAcquire 418 | LLVMAtomicOrderingRelease 419 | LLVMAtomicOrderingAcquireRelease 420 | LLVMAtomicOrderingSequentiallyConsistent]) 421 | 422 | (defenum LLVMAtomicRMWBinOp 423 | 0 424 | [LLVMAtomicRMWBinOpXchg 425 | LLVMAtomicRMWBinOpAdd 426 | LLVMAtomicRMWBinOpSub 427 | LLVMAtomicRMWBinOpAnd 428 | LLVMAtomicRMWBinOpNand 429 | LLVMAtomicRMWBinOpOr 430 | LLVMAtomicRMWBinOpXor 431 | LLVMAtomicRMWBinOpMax 432 | LLVMAtomicRMWBinOpMin 433 | LLVMAtomicRMWBinOpUMax 434 | LLVMAtomicRMWBinOpUMin]) 435 | 436 | (defnative Integer LLVMInitializeCppBackendTargetInfo) 437 | (defnative Integer LLVMInitializeCppBackendTarget) 438 | (defnative Integer LLVMInitializeCppBackendTargetMC) 439 | (defnative Integer LLVMInitializeX86AsmPrinter) 440 | (defnative Integer LLVMInitializeX86AsmParser) 441 | 442 | (defn init-target [] 443 | (LinkInJIT) 444 | (LinkInInterpreter) 445 | (InitializeX86TargetInfo) 446 | (InitializeX86Target) 447 | (InitializeX86TargetMC) 448 | (InitializeX86AsmPrinter) 449 | (InitializeX86AsmParser) 450 | (InitializeCppBackendTargetInfo) 451 | (InitializeCppBackendTarget) 452 | (InitializeCppBackendTargetMC)) 453 | 454 | (init-target) 455 | 456 | (def CCallConv 0) 457 | (def FastCallConv 8) 458 | (def ColdCallConv 9) 459 | (def X86StdcallCallConv 64) 460 | (def X86FastcallCallConv 65) 461 | (def PTXGlobal 71) 462 | (def PTXDevice 72) 463 | 464 | (def AbortProcessAction 0) 465 | (def PrintMessageAction 1) 466 | (def ReturnStatusAction 2) 467 | 468 | 469 | (defn map-parr [fn coll] 470 | (into-array Pointer 471 | (map fn coll))) 472 | 473 | (defn value-at [ptr] 474 | (.getPointer ptr 0)) 475 | 476 | (def kw->linkage 477 | {:extern LLVMExternalLinkage}) 478 | 479 | 480 | 481 | 482 | 483 | 484 | 485 | (defnative Pointer LLVMGetFirstTarget) 486 | (defnative Pointer LLVMGetNextTarget) 487 | (defnative String LLVMGetTargetName) 488 | (defnative String LLVMGetTargetDescription) 489 | (defnative Boolean LLVMTargetHasJIT) 490 | (defnative Boolean LLVMTargetHasTargetMachine) 491 | (defnative Boolean LLVMTargetHasAsmBackend) 492 | (defnative String LLVMGetTarget) 493 | (defnative Pointer LLVMCreateTargetMachine) 494 | (defnative Boolean LLVMTargetMachineEmitToFile) 495 | (defnative Pointer LLVMGetTargetMachineData) 496 | (defnative Pointer LLVMSetDataLayout) 497 | (defnative Integer LLVMSetTarget) 498 | (defnative Pointer LLVMCreateTargetData) 499 | (defnative String LLVMGetTargetMachineTriple) 500 | 501 | 502 | 503 | (defn target-info [t] 504 | {:target t 505 | :name (GetTargetName t) 506 | :desc (GetTargetDescription t) 507 | :jit? (TargetHasJIT t) 508 | :machine? (TargetHasTargetMachine t) 509 | :asm? (TargetHasAsmBackend t)}) 510 | 511 | (defn target-seq 512 | ([] 513 | (let [ft (GetFirstTarget)] 514 | (when ft 515 | (cons (target-info ft) 516 | (lazy-seq 517 | (target-seq ft)))))) 518 | ([t] 519 | (let [nt (GetNextTarget t)] 520 | (when nt 521 | (cons (target-info nt) 522 | (lazy-seq 523 | (target-seq nt))))))) 524 | 525 | 526 | (defn make-target-machine [module] 527 | (let [target (GetTarget module)] 528 | (println "--->" target (target-seq)) 529 | (CreateTargetMachine (:target (second (next (target-seq)))) 530 | "i686-apple-darwin12.2.1" 531 | "core-avx-i" 532 | "" 533 | LLVMCodeGenLevelDefault 534 | LLVMRelocDefault 535 | LLVMCodeModelDefault))) 536 | 537 | 538 | (defn temp-file [prefix ext] 539 | (let [file (java.io.File/createTempFile prefix ext)] 540 | (.deleteOnExit file) 541 | (.getCanonicalPath file))) 542 | 543 | 544 | (defn emit-to-file [module filename] 545 | (let [err (new-pointer) 546 | tm (make-target-machine module)] 547 | (println (GetTargetMachineTriple tm)) 548 | (SetDataLayout module "x86_64-apple-darwin") 549 | (when (TargetMachineEmitToFile tm module filename LLVMAssemblyFile err) 550 | (assert false (.getString (value-at err) 0))) 551 | (DisposeMessage (value-at err)) 552 | )) -------------------------------------------------------------------------------- /src/mjolnir/ssa.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.ssa 2 | (:require [datomic.api :refer [q db] :as d] 3 | [clojure.pprint :refer [pprint]])) 4 | 5 | (defn debug [x] 6 | (pprint x) 7 | x) 8 | 9 | (def ^:dynamic *db-conn* nil) 10 | 11 | (comment 12 | 13 | ssa-format 14 | [ARG_0 :ARG 0] 15 | [ARG_1 :ARG 1] 16 | [MUL_202 :MUL ARG_0 ARG_0] 17 | [MUL_203 :MUL ARG_1 ARG_1] 18 | [ADD_204 :ADD MUL_202 MUL_203] 19 | [FN_205 :GET-GLOBAL "llvm.sqrt"] 20 | [RET_205 :CALL FN_205 MUL_204] 21 | 22 | ) 23 | 24 | (def kw->attrs 25 | {:one [:db/cardinality :db.cardinality/one] 26 | :many [:db/cardinality :db.cardinality/many] 27 | :ref [:db/valueType :db.type/ref] 28 | :keyword [:db/valueType :db.type/keyword] 29 | :int [:db/valueType :db.type/long] 30 | :float [:db/valueType :db.type/double] 31 | :boolean [:db/valueType :db.type/boolean] 32 | :string [:db/valueType :db.type/string] 33 | :unique [:db/unique :db.unique/value]}) 34 | 35 | (defn default-schema [] 36 | {:list/tail #{:one :ref} 37 | :fn/type #{:one :ref} 38 | :fn/argument-names #{:one :ref} 39 | :fn/name #{:one :string} 40 | :fn/body #{:one :ref} 41 | :fn/entry-block #{:one :ref} 42 | :fn/extern? #{:one :boolean} 43 | 44 | :fn.arg/type #{:one :ref} 45 | :fn.arg/idx #{:one :int} 46 | :fn.arg/fn #{:one :ref} 47 | 48 | :global/name #{:one :string} 49 | :global/type #{:one :ref} 50 | :global/val #{:one :ref} 51 | 52 | :inst/block #{:one :ref} 53 | :inst/next #{:one :ref} 54 | :inst/type #{:one :keyword} 55 | 56 | :inst/args #{:many :ref} 57 | 58 | :phi/block #{:one :ref} 59 | :phi.value/node #{:one :ref} 60 | :phi.value/block #{:one :ref} 61 | :phi.value/value #{:one :ref} 62 | 63 | :inst/return-value #{:one :ref} 64 | 65 | :block/fn #{:one :ref} 66 | :block/name #{:one :string} 67 | :block/terminator-inst #{:one :ref} 68 | 69 | :const/int-value #{:one :int} 70 | :const/float-value #{:one :float} 71 | :const/type #{:one :ref} 72 | 73 | :argument/name #{:one :string} 74 | :argument/idx #{:one :int} 75 | 76 | :type.fn/return #{:one :ref} 77 | :type.fn/arguments #{:one :ref} 78 | 79 | :list/head #{:one :ref} 80 | 81 | :node/type #{:one :keyword} 82 | :node/return-type #{:one :ref} 83 | 84 | :type/width #{:one :int} 85 | 86 | :type/element-type #{:one :ref} 87 | :type/length #{:one :int} 88 | 89 | :type.member/idx #{:one :int} 90 | :type.member/struct #{:one :ref} 91 | :type.member/type #{:one :ref} 92 | :type.struct/extends #{:one :ref} 93 | :type.struct/name #{:one :string} 94 | :type.member/name #{:one :keyword} 95 | 96 | :type/unknown #{:one :keyword} 97 | 98 | :error/key #{:one :keyword} 99 | :error/calue #{:one :string} 100 | 101 | :inst.binop/type #{:one :keyword} 102 | :inst.binop/sub-type #{:one :keyword} 103 | :inst.arg/idx #{:one :int} 104 | 105 | :inst.cast/type #{:one :keyword} 106 | 107 | :inst.set/member #{:one :keyword} 108 | :inst.get/member #{:one :keyword} 109 | 110 | :inst.gbl/name #{:one :string} 111 | :inst.call/fn #{:one :ref} 112 | 113 | :inst.cmp/pred #{:one :keyword} 114 | :isnt.cmp/sub-pred #{:one :keyword} 115 | 116 | :inst.sizeof/type #{:one :ref} 117 | 118 | :inst.callp/fn #{:one :ref} 119 | 120 | :inst.malloc/type #{:one :ref} 121 | :inst.new/type #{:one :ref} 122 | :inst.new/count #{:one :ref} 123 | :inst.new/size #{:one :ref} 124 | 125 | :inst.atomic/op #{:one :keyword} 126 | 127 | ;; args 128 | :inst.arg/arg0 #{:one :ref} 129 | :inst.arg/arg1 #{:one :ref} 130 | :inst.arg/arg2 #{:one :ref} 131 | :inst.arg/arg3 #{:one :ref} 132 | :inst.arg/arg4 #{:one :ref} 133 | :inst.arg/arg5 #{:one :ref} 134 | :inst.arg/arg6 #{:one :ref} 135 | :inst.arg/arg7 #{:one :ref} 136 | :inst.arg/arg8 #{:one :ref} 137 | :inst.arg/arg9 #{:one :ref} 138 | :inst.arg/arg10 #{:one :ref} 139 | :inst.arg/arg11 #{:one :ref} 140 | }) 141 | 142 | 143 | (def idx->arg 144 | [:inst.arg/arg0 145 | :inst.arg/arg1 146 | :inst.arg/arg2 147 | :inst.arg/arg3 148 | :inst.arg/arg4 149 | :inst.arg/arg5 150 | :inst.arg/arg6 151 | :inst.arg/arg7 152 | :inst.arg/arg8 153 | :inst.arg/arg9 154 | :inst.arg/arg10 155 | :inst.arg/arg11]) 156 | 157 | (defn error-messages [] 158 | {:error.fn/return-type-match "Return instructions must return the same type as their eclosing function"}) 159 | 160 | ;; rules 161 | 162 | (defn assert-schema [conn desc] 163 | (->> (for [[id attrs] desc] 164 | (merge 165 | {:db/id (d/tempid :db.part/db) 166 | :db/ident id 167 | :db/index true 168 | :db.install/_attribute :db.part/db} 169 | (reduce 170 | (fn [m attr] 171 | (apply assoc m (kw->attrs attr))) 172 | {} 173 | attrs))) 174 | (d/transact conn) 175 | deref)) 176 | 177 | (defn get-query [sing] 178 | `[:find ~'?id 179 | :where 180 | ~@(map (fn [[k v]] 181 | (vector '?id k v)) 182 | sing)]) 183 | 184 | (defn find-singleton [db sing] 185 | (assert db (pr-str db)) 186 | (let [results (->> (q (get-query sing) db) 187 | (filter (fn [[id]] 188 | (= (count sing) 189 | (count (d/touch (d/entity db id)))))))] 190 | (assert (>= 1 (count results))) 191 | (ffirst results))) 192 | 193 | (defrecord TxPlan [conn db singletons new-ents tempids]) 194 | 195 | 196 | #_(defn new-plan [conn] ) 197 | 198 | (defn commit 199 | "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" 200 | [{:keys [conn db new-ents updates valid-ids] :as plan}] 201 | (assert (and conn db)) 202 | (let [ents (reduce 203 | (fn [acc [ent id]] 204 | (assert (not (get acc id)) "Duplicate ids") 205 | (assoc acc id (assoc ent :db/id id))) 206 | {} 207 | new-ents) 208 | _ (assert (= (set (keys ents)) 209 | (set (keys valid-ids))) 210 | (pr-str (count (set (keys ents))) 211 | (count (set (keys valid-ids))) 212 | (count new-ents))) 213 | 214 | data (concat #_(mapcat (fn [ent] 215 | (let [ent (dissoc ent :db/id)] 216 | (map (partial vector :db/add (:db/id ent)) 217 | (keys ent) 218 | (vals ent)))) 219 | (vals ents)) 220 | (vals ents) 221 | (map (fn [[id k v]] 222 | [:db/add id k v]) 223 | updates)) 224 | {:keys [db-before db-after tempids tx-data]} 225 | @(d/transact conn data) 226 | ptempids (zipmap 227 | (keys (:tempids plan)) 228 | (map (partial d/resolve-tempid db-after tempids) 229 | (vals (:tempids plan))))] 230 | (assoc plan 231 | :tempids ptempids 232 | :db db-after 233 | :db-before db-before 234 | :new-ents nil 235 | :singletons nil))) 236 | 237 | (defn plan-id 238 | [plan val] 239 | (if-let [v (get-in plan [:tempids val])] 240 | v 241 | (assert false (str "Can't find " val)))) 242 | 243 | (defn plan-ent 244 | [plan val] 245 | (d/entity (:db plan) (get-in plan [:tempids val]))) 246 | 247 | (defn to-seq [head] 248 | (when head 249 | (cons (:list/head head) 250 | (lazy-seq (to-seq (:list/tail head)))))) 251 | 252 | (defn singleton 253 | ([sing] 254 | (singleton sing nil)) 255 | ([sing key] 256 | (fn [plan] 257 | (if-let [id (get-in plan [:singletons sing])] 258 | [id plan] 259 | (if-let [q (find-singleton (:db plan) sing)] 260 | [q (assoc-in plan [:singletons sing] q)] 261 | (let [newid (d/tempid :db.part/user)] 262 | [newid (-> plan 263 | (assoc-in [:singletons sing] newid) 264 | (assoc-in [:new-ents sing] newid) 265 | (assoc-in [:tempids key] newid) 266 | (assoc-in [:valid-ids newid] newid))])))))) 267 | 268 | (defn assert-entity 269 | ([ent] 270 | (assert-entity ent nil)) 271 | ([ent key] 272 | (fn [plan] 273 | (let [newid (d/tempid :db.part/user) 274 | ent (assoc ent :db/id newid)] 275 | (assert (not= 1 (count ent)) (str "Cannot assert a empty entity " ent)) 276 | [newid (-> plan 277 | (assoc-in [:new-ents ent] newid) 278 | (assoc-in [:tempids key] newid) 279 | (assoc-in [:valid-ids newid] newid))])))) 280 | 281 | (defn update-entity [ent & attrs-vals] 282 | (let [pairs (partition 2 attrs-vals)] 283 | (fn [plan] 284 | (assert (get (:valid-ids plan) ent) (pr-str "Must give entity id" ent "=>" (:valid-ids plan))) 285 | (let [new-plan (reduce 286 | (fn [plan [k v]] 287 | (update-in plan [:updates] (fnil conj []) [ent k v])) 288 | plan 289 | pairs)] 290 | [ent new-plan])))) 291 | 292 | (defn update-all [itms] 293 | (fn [plan] 294 | (let [new-plan (reduce 295 | (fn [plan data] 296 | (update-in plan [:updates] (fnil conj []) data)) 297 | plan 298 | itms)] 299 | [nil new-plan]))) 300 | 301 | (defn add-all [itms] 302 | (fn [plan] 303 | (reduce 304 | (fn [[ids plan] f] 305 | (let [[id plan] (f plan)] 306 | [(conj ids id) plan])) 307 | [[] plan] 308 | itms))) 309 | 310 | (defn assert-all [ents] 311 | (fn [plan] 312 | (reduce 313 | (fn [[ids plan] [ent key]] 314 | (assert (not= 0 (count ent)) "Cannot assert an empty entity") 315 | (let [[id plan] ((assert-entity ent key) plan)] 316 | [(conj ids id) plan])) 317 | [[] plan] 318 | ents))) 319 | 320 | (defn- with-bind [id expr psym body] 321 | `(fn [~psym] 322 | (let [[~id ~psym] ( ~expr ~psym)] 323 | (assert ~psym "Nill plan") 324 | ~body))) 325 | 326 | (defmacro gen-plan [binds id-expr] 327 | (let [binds (partition 2 binds) 328 | psym (gensym "plan_") 329 | forms (reduce 330 | (fn [acc [id expr]] 331 | (concat acc `[[~id ~psym] (~expr ~psym)])) 332 | [] 333 | binds)] 334 | `(fn [~psym] 335 | (let [~@forms] 336 | [~id-expr ~psym])))) 337 | 338 | (defn assoc-plan [key val] 339 | (fn [plan] 340 | [nil (assoc plan key val)])) 341 | 342 | (defn assoc-in-plan [path val] 343 | (fn [plan] 344 | [nil (assoc-in plan path val)])) 345 | 346 | (defn get-in-plan [path] 347 | (fn [plan] 348 | [(get-in plan path) plan])) 349 | 350 | (defn push-binding [key value] 351 | (fn [plan] 352 | [nil (update-in plan [:bindings key] conj value)])) 353 | 354 | (defn push-alter-binding [key f & args] 355 | (fn [plan] 356 | [nil (update-in plan [:bindings key] 357 | #(conj % (apply f (first %) args)))])) 358 | 359 | (defn get-binding [key] 360 | (fn [plan] 361 | [(first (get-in plan [:bindings key])) plan])) 362 | 363 | (defn pop-binding [key] 364 | (fn [plan] 365 | [(first (get-in plan [:bindings key])) 366 | (update-in plan [:bindgins key] pop)])) 367 | 368 | (defn no-op [] 369 | (fn [plan] 370 | [nil plan])) 371 | 372 | (defn get-plan [planval conn] 373 | (assert (ifn? planval)) 374 | (let [val (planval (->TxPlan conn (db conn) {} {} {}))] 375 | (assert (vector? val)) 376 | (second val))) 377 | 378 | (defn- assert-list-node [last id] 379 | (gen-plan 380 | [ent-id (let [ent (merge 381 | (if last 382 | {:list/tail last} 383 | {}) 384 | {:list/head id})] 385 | (singleton ent ent))] 386 | ent-id)) 387 | 388 | (defn assert-seq [seq] 389 | (fn [plan] 390 | (reduce 391 | (fn [[last-id plan] id] 392 | ((assert-list-node last-id id) plan)) 393 | [nil plan] 394 | (reverse seq)))) 395 | 396 | ;; True ssa stuff here, blocks instructions etc. 397 | (defn add-block [fn-id nm] 398 | (let [blk {:block/fn fn-id 399 | :block/name nm 400 | :node/type :node.type/block}] 401 | (gen-plan 402 | [blk (assert-entity blk blk)] 403 | blk))) 404 | 405 | (defn mark-extern-fn [fn-id] 406 | (gen-plan 407 | [_ (update-entity fn-id :fn/extern? true)] 408 | nil)) 409 | 410 | (defn set-block [block-id] 411 | (fn [plan] 412 | [block-id (assoc plan :block-id block-id)])) 413 | 414 | (defn add-entry-block [fn-id] 415 | (gen-plan 416 | [blk (add-block fn-id "entry") 417 | _ (assoc-plan :block-id blk) 418 | _ (update-entity fn-id :fn/entry-block blk)] 419 | blk)) 420 | 421 | 422 | (defn no-type [] 423 | (gen-plan 424 | [a (singleton {:node/type :node.type/unknown})] 425 | a)) 426 | 427 | 428 | (defn get-block [] 429 | (fn [plan] 430 | [(:block-id plan) plan])) 431 | 432 | (defn add-phi 433 | "Adds a phi node to a block. In Mjolnir phi nodes are always attached to the start of a block. 434 | The order of the nodes cannot be set, as it shouldn't matter in the output seimantics of the code" 435 | [] 436 | (gen-plan 437 | [no-type-id (no-type) 438 | block (get-block) 439 | phi-id (assert-entity {:node/type :node.type/phi 440 | :phi/block block 441 | :inst/type :inst.type/phi 442 | :node/return-type no-type-id})] 443 | phi-id)) 444 | 445 | (defn add-to-phi 446 | "adds an incomming value to a phi node" 447 | [phi-node block-id value] 448 | (gen-plan 449 | [val (assert-entity {:node/type :node.type/phi-value 450 | :phi.value/node phi-node 451 | :phi.value/block block-id 452 | :phi.value/value value})] 453 | val)) 454 | 455 | (defn terminate-block 456 | "Sets the terminator instruction for a block" 457 | [inst & args] 458 | {:pre (every? (complement nil?) args)} 459 | (gen-plan 460 | [block (get-block) 461 | inst (assert-entity (reduce 462 | (fn [acc [idx arg]] 463 | (assoc acc (idx->arg idx) arg)) 464 | {:inst/type inst} 465 | (map vector 466 | (range) 467 | args))) 468 | _ (assoc-in-plan [:state block :terminated] true) 469 | _ (update-entity block :block/terminator-inst inst)] 470 | block)) 471 | 472 | (defn terminated? 473 | [block] 474 | (gen-plan 475 | [term (get-in-plan [:state block])] 476 | term)) 477 | 478 | (defn arg-ids [attrs-map] 479 | (let [ks (concat [:inst.call/fn 480 | :inst.callp/fn] 481 | idx->arg)] 482 | (->> (map attrs-map ks) 483 | (remove nil?)))) 484 | 485 | (defn add-instruction 486 | ([instruction attrs-map] 487 | (add-instruction instruction attrs-map nil)) 488 | ([instruction attrs-map key] 489 | (fn [plan] 490 | (let [block-id (:block-id plan) 491 | prev-instruction-id (get-in plan [:block-states block-id :prev-instruction-id])] 492 | ((add-instruction block-id prev-instruction-id instruction attrs-map key) plan)))) 493 | ([block-id prev-instruction-id instruction attrs-map key] 494 | (gen-plan 495 | [no-type-id (no-type) 496 | inst-id (assert-entity 497 | (let [mp (merge 498 | {:inst/block block-id 499 | :inst/type instruction 500 | :node/type :node.type/inst} 501 | attrs-map)] 502 | (if (:node/return-type mp) 503 | mp 504 | (assoc mp :node/return-type no-type-id))) 505 | key) 506 | _ (if prev-instruction-id 507 | (update-entity prev-instruction-id :inst/next inst-id) 508 | (no-op)) 509 | _ (add-all (map #(update-entity inst-id :inst/args %) 510 | (arg-ids attrs-map))) 511 | _ (assoc-in-plan [:block-states block-id :prev-instruction-id] inst-id)] 512 | inst-id))) 513 | 514 | (defn instruction-seq [block] 515 | ;; Get all the instructions, bounce up to the top, then return a seq 516 | ;; of all 517 | (->> (:inst/_block block) 518 | (map d/touch) 519 | first 520 | (iterate (comp first :inst/_next)) 521 | (take-while (complement nil?)) 522 | last 523 | (iterate :inst/next) 524 | (take-while (complement nil?)))) 525 | 526 | 527 | (defn new-db [] 528 | (let [url (str "datomic:mem://ssa" (name (gensym)))] 529 | (d/create-database url) 530 | (let [conn (d/connect url)] 531 | (assert-schema conn (default-schema)) 532 | conn))) 533 | 534 | 535 | (defprotocol IToPlan 536 | (add-to-plan [this] 537 | "assert this item as datoms into the db and return the id of this entity")) 538 | 539 | (comment 540 | (defmulti print-type :node/type) 541 | 542 | (defmethod print-node :type.fn 543 | (println (str "fn-type(" ))) 544 | 545 | (defn print-fn [f] 546 | (println "Fn: " (:fn/name f))) 547 | 548 | (defn print-module [plan] 549 | (let [fns (->> (q '[:find ?id 550 | :where [?id :fn/name ?name]] 551 | (:db plan)) 552 | (mapv (comp (partial d/entity (:db plan)) 553 | first)))] 554 | (doseq [fn fns] 555 | (print-fn fn))))) 556 | 557 | #_(defn -main [] 558 | (to-datomic-schema (default-schema)) 559 | (println (transact-new conn {:node/type :type/int 560 | :type.int/width 32})) 561 | (println (transact-singleton conn {:node/type :type/int 562 | :type.int/width 32}))) -------------------------------------------------------------------------------- /src/mjolnir/ssa_rules.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.ssa-rules 2 | (:require [clojure.pprint :refer [pprint]] 3 | [datomic.api :refer [db q] :as d])) 4 | 5 | (def rules (atom [])) 6 | 7 | (defmacro defrule [name args doc & body] 8 | #_(println "Registered rule" name ) 9 | (swap! rules conj `[(~name ~@args) 10 | ~@body]) 11 | nil) 12 | 13 | ;; Utility 14 | 15 | (defrule global-def [?id ?name ?type] 16 | "Functions are global entities" 17 | [?id :node/type :node.type/fn] 18 | [?id :fn/name ?name] 19 | [?id :fn/type ?type]) 20 | 21 | (defrule global-def [?id ?name ?type] 22 | "Functions are global entities" 23 | [?id :global/name ?name] 24 | [?id :global/type ?type]) 25 | 26 | 27 | ;; Inference Rules 28 | 29 | (defrule infer-node [?id ?attr ?val] 30 | "infer return-types" 31 | [?no-type :node/type :node.type/unknown] 32 | [?id :node/return-type ?no-type] 33 | (return-type ?id ?val) 34 | [(identity :node/return-type) ?attr]) 35 | 36 | #_(defrule infer-binop-node [?id ?attr ?val] 37 | "infer binop subtypes" 38 | (infer-binop ?id ?val) 39 | [(identity :inst.binop/sub-type) ?attr]) 40 | 41 | #_(defrule infer-node [?id ?attr ?val] 42 | "infer cmp" 43 | (infer-cmp-node ?id ?attr ?val)) 44 | 45 | 46 | (defrule infer-node [?id ?attr ?val] 47 | "infer casts" 48 | [?id :inst/type :inst.type/cast] 49 | [?id :inst.cast/type :inst.cast/unknown] 50 | [?id :inst.arg/arg0 ?arg0] 51 | (return-type ?arg0 ?arg0-t) 52 | [?id :node/return-type ?arg1-t] 53 | (cast-subtype ?id ?arg0-t ?arg1-t ?val) 54 | [(identity :inst.cast/type) ?attr]) 55 | 56 | ;; 57 | 58 | 59 | (defrule return-type [?id ?type] 60 | "Anything with :node/return-type returns that type" 61 | [?id :node/return-type ?type] 62 | [?no-type :node/type :node.type/unknown] 63 | [(not= ?type ?no-type)]) 64 | 65 | (defrule return-type [?id ?type] 66 | "Consts return their given type, if it exists" 67 | [?id :inst/type :inst.type/const] 68 | [?id :const/type ?type]) 69 | 70 | (defrule return-type [?id ?type] 71 | "Binops return the same type as their args" 72 | [?id :inst/type :inst.type/binop] 73 | [?id :inst.arg/arg0 ?arg0] 74 | [?id :inst.arg/arg1 ?arg1] 75 | #_(return-type ?arg0 ?type) 76 | (return-type ?arg1 ?type)) 77 | 78 | (defrule infer-phi-return-type [?id ?type] 79 | "Phi nodes always return the return type of one of their values" 80 | [?phi :phi.value/node ?id] 81 | [?phi :phi.value/value ?arg] 82 | [?arg :node/return-type ?type] 83 | #_(return-type ?arg ?type)) 84 | 85 | (defrule return-type [?id ?type] 86 | "Phi nodes always return the return type of one of their values" 87 | [?phi :phi.value/node ?id] 88 | [?phi :phi.value/value ?arg] 89 | #_[?arg :node/return-type ?type] 90 | (return-type ?arg ?type)) 91 | 92 | (defrule return-type [?id ?type] 93 | "Globals return the type of the matching global" 94 | [?id :inst/type :inst.type/gbl] 95 | [?id :inst.gbl/name ?name] 96 | (global-def ?gbl ?name ?type)) 97 | 98 | (defrule return-type [?id ?type] 99 | "Function calls return the return type of the function they are calling" 100 | [?id :inst/type :inst.type/call] 101 | [?id :inst.call/fn ?fn-src] 102 | (return-type ?fn-src ?fn-t) 103 | [?fn-t :type.fn/return ?type]) 104 | 105 | (defrule return-type [?id ?type] 106 | "Function pointer calls return the return type of the function they are calling" 107 | [?id :inst/type :inst.type/callp] 108 | [?id :inst.callp/fn ?fn-src] 109 | (return-type ?fn-src ?ptr-t) 110 | [?ptr-t :type/element-type ?fn-t] 111 | [?fn-t :type.fn/return ?type]) 112 | 113 | (defrule return-type [?id ?type] 114 | "Arg instructions return the type from the function type" 115 | [?id :inst/type :inst.type/arg] 116 | [?id :inst/block ?block] 117 | [?block :block/fn ?fn] 118 | [?fn :fn/type ?fn-t] 119 | [?arg-node :fn.arg/fn ?fn-t] 120 | [?id :inst.arg/idx ?idx] 121 | [?arg-node :fn.arg/idx ?idx] 122 | [?arg-node :fn.arg/type ?type]) 123 | 124 | 125 | (defrule return-type [?id ?type] 126 | "Store returns the ptr type" 127 | [?id :inst/type :inst.type/store] 128 | [?id :inst.arg/arg0 ?arg0] 129 | (return-type ?arg0 ?type)) 130 | 131 | (defrule return-type [?id ?type] 132 | "ASet returns the arr type" 133 | [?id :inst/type :inst.type/aset] 134 | [?id :inst.arg/arg0 ?arg0] 135 | [?arg0 :inst/type ?v] 136 | (return-type ?arg0 ?type)) 137 | 138 | (defrule return-type [?id ?type] 139 | "AGet returns the element type" 140 | [?id :inst/type :inst.type/aget] 141 | [?id :inst.arg/arg0 ?arg0] 142 | (return-type ?arg0 ?arg0-t) 143 | [?arg0-t :type/element-type ?type] 144 | [?type :node/type ?nt]) 145 | 146 | (defrule return-type [?id ?type] 147 | "Nth returns the same type as the input" 148 | [?id :inst/type :inst.type/nth] 149 | [?id :inst.arg/arg0 ?arg0] 150 | (return-type ?arg0 ?type)) 151 | 152 | 153 | 154 | (defrule member-idx [?tp ?nm ?idx ?member-tp] 155 | "Gets the idx of a member" 156 | [?mbr :type.member/struct ?tp] 157 | [?mbr :type.member/idx ?idx] 158 | [?mbr :type.member/name ?nm] 159 | [?mbr :type.member/type ?member-tp]) 160 | 161 | (defrule return-type [?id ?type] 162 | "Set returns the same type as the ptr" 163 | [?id :inst/type :inst.type/set] 164 | [?id :inst.arg/arg0 ?arg0] 165 | (return-type ?arg0 ?type)) 166 | 167 | (defrule return-type [?id ?type] 168 | "Get returns the member type" 169 | [?id :inst/type :inst.type/get] 170 | [?id :inst.arg/arg0 ?arg0] 171 | (return-type ?arg0 ?arg0-t) 172 | [?arg0-t :type/element-type ?etype] 173 | [?id :inst.get/member ?nm] 174 | (member-idx ?etype ?nm ?idx ?type)) 175 | 176 | (defrule return-type [?id ?type] 177 | "Atomic ops return the same type as the input value" 178 | [?id :inst/type :inst.type/atomic] 179 | [?id :inst.arg/arg1 ?arg1] 180 | (return-type ?arg1 ?type)) 181 | 182 | 183 | 184 | 185 | 186 | (defrule validate [?id ?msg] 187 | "Binops must have the same types for all args" 188 | [?id :inst/type :inst.type/binop] 189 | [?id :inst.arg/arg0 ?arg0] 190 | [?id :inst.arg/arg1 ?arg1] 191 | (return-type ?arg0 ?arg0-tp) 192 | (return-type ?arg1 ?arg1-tp) 193 | #_(return-type ?id ?this-tp) 194 | [(not= ?arg0-tp ?arg1-tp)] 195 | [(identity "Binop args must match return type") ?msg]) 196 | 197 | 198 | (defn func-arg-count-dont-match? [db tp-id call-id] 199 | (let [call-ent (d/entity db call-id) 200 | tp-ent (d/entity db tp-id)] 201 | (not= (count (:fn.arg/_fn tp-ent)) 202 | ;; decrement this, as we include :inst.call/fn 203 | (dec (count (:inst/args call-ent)))))) 204 | 205 | (defrule validate [?id ?msg] 206 | "Calls must match argument counts" 207 | [?id :inst/type :inst.type/call] 208 | [?id :inst.call/fn ?gbl] 209 | [?gbl :inst.gbl/name ?name] 210 | [?gbl :node/return-type ?tp] 211 | [(mjolnir.ssa-rules/func-arg-count-dont-match? $ ?tp ?id)] 212 | [(str "Call signature doesn't match function, calling " ?name) ?msg]) 213 | 214 | 215 | (defrule validate [?id ?msg] 216 | "Args must match types" 217 | [?id :inst/type :inst.type/call] 218 | [?id :inst.arg/arg0 ?arg] 219 | [?arg :node/return-type ?arg-t] 220 | [?id :inst.call/fn ?fn] 221 | [?fn :inst.gbl/name ?name] 222 | [?fn :node/return-type ?fn-t] 223 | [?fn-arg :fn.arg/fn ?fn-t] 224 | [?fn-arg :fn.arg/idx 0] 225 | [?fn-arg :fn.arg/type ?fn-arg-t] 226 | [(not= ?fn-arg-t ?arg-t)] 227 | [?fn-arg-t :node/type ?fn-arg-t-node] 228 | [?arg-t :node/type ?arg-t-node] 229 | [?id :inst/block ?block] 230 | [?block :block/fn ?parent-fn] 231 | [?parent-fn :fn/name ?parent-fn-name] 232 | [(str "Arg0 doesn't match in call to " 233 | ?name 234 | " types " 235 | ?fn-arg-t-node 236 | " " 237 | ?arg-t-node 238 | " in " 239 | ?parent-fn-name) ?msg]) 240 | 241 | (defrule validate [?id ?msg] 242 | "Args must match types" 243 | [?id :inst/type :inst.type/call] 244 | [?id :inst.arg/arg1 ?arg] 245 | [?arg :node/return-type ?arg-t] 246 | [?id :inst.call/fn ?fn] 247 | [?fn :inst.gbl/name ?name] 248 | [?fn :node/return-type ?fn-t] 249 | [?fn-arg :fn.arg/fn ?fn-t] 250 | [?fn-arg :fn.arg/idx 1] 251 | [?fn-arg :fn.arg/type ?fn-arg-t] 252 | [(not= ?fn-arg-t ?arg-t)] 253 | [(str "Arg1 doesn't match in call to " ?name) ?msg]) 254 | 255 | (defrule validate [?id ?msg] 256 | "Args must match types" 257 | [?id :inst/type :inst.type/call] 258 | [?id :inst.arg/arg2 ?arg] 259 | [?arg :node/return-type ?arg-t] 260 | [?id :inst.call/fn ?fn] 261 | [?fn :inst.gbl/name ?name] 262 | [?fn :node/return-type ?fn-t] 263 | [?fn-arg :fn.arg/fn ?fn-t] 264 | [?fn-arg :fn.arg/idx 2] 265 | [?fn-arg :fn.arg/type ?fn-arg-t] 266 | [(not= ?fn-arg-t ?arg-t)] 267 | [(str "Arg2 doesn't match in call to " ?name) ?msg]) 268 | 269 | 270 | 271 | 272 | ;; Binop rules - These rules define an attribute that helps emitters 273 | ;; decide if a binop is a Float or Int operation. FMul is different 274 | ;; from IMul, so this code specializes that information. 275 | 276 | (comment 277 | (defrule infer-binop [?id ?op] 278 | "A binop of two ints " 279 | [?id :inst/type :inst.type/binop] 280 | [?id :inst.arg/arg0 ?arg0] 281 | [?id :inst.arg/arg1 ?arg1] 282 | (return-type ?arg0 ?arg0-t) 283 | (return-type ?arg1 ?arg1-t) 284 | (binop-subtype ?id ?arg0-t ?arg1-t ?op)) 285 | 286 | 287 | (defrule binop-subtype [?type ?arg0-t ?arg1-t ?op] 288 | "Int + resolves to :iadd" 289 | [?arg0-t :node/type :type/int] 290 | [?arg1-t :node/type :type/int] 291 | [?type :inst.binop/type ?binop] 292 | [(mjolnir.ssa-rules/binop-int-translation ?binop) ?op]) 293 | 294 | (defrule binop-subtype [?type ?arg0-t ?arg1-t ?op] 295 | "Float + resolves to :iadd" 296 | [?arg0-t :node/type :type/float] 297 | [?arg1-t :node/type :type/float] 298 | [?type :inst.binop/type ?binop] 299 | [(mjolnir.ssa-rules/binop-float-translation ?binop) ?op])) 300 | 301 | 302 | ;; Cast subtype 303 | 304 | (defrule cast-subtype [?id ?arg0-t ?arg1-t ?op] 305 | "Larger Ints truncate to smaller ints" 306 | [?arg0-t :node/type :type/int] 307 | [?arg1-t :node/type :type/int] 308 | [?arg0-t :type/length ?arg0-length] 309 | [?arg1-t :type/length ?arg1-length] 310 | [(> ?arg0-length ?arg1-length)] 311 | [(identity :inst.cast.type/trunc) ?op]) 312 | 313 | (defrule cast-subtype [?id ?arg0-t ?arg1-t ?op] 314 | "Larger Ints truncate to smaller ints" 315 | [?arg0-t :node/type :type/int] 316 | [?arg1-t :node/type :type/int] 317 | [?arg0-t :type/length ?arg0-length] 318 | [?arg1-t :type/length ?arg1-length] 319 | [(< ?arg0-length ?arg1-length)] 320 | [(identity :inst.cast.type/zext) ?op]) 321 | 322 | (defrule cast-subtype [?id ?arg0-t ?arg1-t ?op] 323 | "Floats cast to int" 324 | [?arg0-t :node/type :type/float] 325 | [?arg1-t :node/type :type/int] 326 | [(identity :inst.cast.type/fp-to-si) ?op]) 327 | 328 | (defrule cast-subtype [?id ?arg0-t ?arg1-t ?op] 329 | "Ints cast to floats" 330 | [?arg0-t :node/type :type/int] 331 | [?arg1-t :node/type :type/float] 332 | [(identity :inst.cast.type/si-to-fp) ?op]) 333 | 334 | (defrule cast-subtype [?id ?arg0-t ?arg1-t ?op] 335 | "Pointers are bitcast" 336 | [?arg0-t :node/type :type/pointer] 337 | [?arg1-t :node/type :type/pointer] 338 | [(identity :inst.cast.type/bitcast) ?op]) 339 | 340 | (defrule cast-subtype [?id ?arg0-t ?arg1-t ?op] 341 | "Functions can be bitcast" 342 | [?arg0-t :node/type :type/fn] 343 | [?arg1-t :node/type :type/pointer] 344 | [(identity :inst.cast.type/bitcast) ?op]) 345 | 346 | (defrule cast-subtype [?id ?arg0-t ?arg1-t ?op] 347 | "Larger Ints truncate to smaller ints" 348 | [?arg0-t :node/type :type/pointer] 349 | [?arg1-t :node/type :type/int] 350 | [(identity :inst.cast.type/ptr-to-int) ?op]) 351 | 352 | (defrule cast-subtype [?id ?arg0-t ?arg1-t ?op] 353 | "Larger Ints truncate to smaller ints" 354 | [?arg0-t :node/type :type/int] 355 | [?arg1-t :node/type :type/pointer] 356 | [(identity :inst.cast.type/int-to-ptr) ?op]) 357 | 358 | 359 | 360 | ;; Cmp predicate inference 361 | 362 | 363 | (def cmp-map 364 | {[:type/int :type/int :inst.cmp.pred/=] :inst.cmp.sub-pred/int-eq 365 | [:type/int :type/int :inst.cmp.pred/not=] :inst.cmp.sub-pred/int-ne 366 | [:type/int :type/int :inst.cmp.pred/>] :inst.cmp.sub-pred/int-sgt 367 | [:type/int :type/int :inst.cmp.pred/<] :inst.cmp.sub-pred/int-slt 368 | [:type/int :type/int :inst.cmp.pred/<=] :inst.cmp.sub-pred/int-sle 369 | [:type/int :type/int :inst.cmp.pred/>=] :inst.cmp.sub-pred/int-sge 370 | 371 | [:type/float :type/float :inst.cmp.pred/=] :inst.cmp.sub-pred/real-oeq 372 | [:type/float :type/float :inst.cmp.pred/not=] :inst.cmp.sub-pred/real-one 373 | [:type/float :type/float :inst.cmp.pred/>] :inst.cmp.sub-pred/real-ogt 374 | [:type/float :type/float :inst.cmp.pred/<] :inst.cmp.sub-pred/real-olt 375 | [:type/float :type/float :inst.cmp.pred/<=] :inst.cmp.sub-pred/real-ole 376 | [:type/float :type/float :inst.cmp.pred/>=] :inst.cmp.sub-pred/real-oge}) 377 | 378 | #_(defrule infer-cmp-node [?id ?attr ?val] 379 | "Infer cmp predicate" 380 | [?id :inst/type :inst.type/cmp] 381 | [?id :inst.arg/arg0 ?arg0] 382 | [?id :inst.arg/arg1 ?arg1] 383 | [?id :inst.cmp/pred ?pred] 384 | (return-type ?arg0 ?arg0-t) 385 | (return-type ?arg1 ?arg1-t) 386 | [?arg0-t :node/type ?arg0-tg] 387 | [?arg1-t :node/type ?arg1-tg] 388 | [(vector ?arg0-tg ?arg1-tg ?pred) ?key] 389 | [(mjolnir.ssa-rules/cmp-map ?key) ?val] 390 | [(identity :inst.cmp/sub-pred) ?attr]) 391 | 392 | 393 | 394 | 395 | 396 | (comment 397 | 398 | ;; For a block, gets the instructions in the block 399 | (defrule instruction-seq [?block ?inst] 400 | "All instructions attached to the block should be considered" 401 | [?block :inst/block ?inst]) 402 | 403 | (defrule instruction-seq [?block ?inst] 404 | "Terminator instructions should be considered" 405 | [?block :block/terminator-inst ?inst]) 406 | 407 | (defrule depends-on [?block-a ?block-b] 408 | "Rule passes if block-a requires block-b before it can be built" 409 | [(mjolnir.ssa-rules/arg-k) [?attr ...]] 410 | (instruction-seq ?block-a ?inst-a) 411 | [?inst-a ?attr ?inst-b] 412 | [?inst-b :inst/block ?block-b] 413 | [(not= ?block-a ?block-b)]) 414 | 415 | (defrule depends-on [?block-a ?block-b] 416 | "Rule passes if block-a requires block-b before it can be built" 417 | [(mjolnir.ssa-rules/arg-k) [?attr ...]] 418 | (instruction-seq ?block-a ?inst-a) 419 | [?inst-a ?attr ?inst-b] 420 | [?inst-b :phi/block ?block-b] 421 | [(not= ?block-a ?block-b)])) -------------------------------------------------------------------------------- /src/mjolnir/targets/darwin.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.targets.darwin 2 | (:require 3 | [mjolnir.expressions :as expr] 4 | [mjolnir.targets.target :as target] 5 | [clojure.java.shell :as shell] 6 | [mjolnir.types :as types] 7 | [mjolnir.targets.x86-cpus :as x86-cpus] 8 | [mjolnir.llvmc :as llvm]) 9 | (:import [com.sun.jna Native Pointer Memory Function])) 10 | 11 | 12 | (defrecord DarwinTarget [march vendor os llvm-target] 13 | target/ITarget 14 | (pointer-type [this] 15 | (types/->IntegerType 32 #_(* (llvm/PointerSize (:target llvm-target)) 8))) 16 | (default-address-space [this] 17 | 0) 18 | (get-calling-conv [this extern?] 19 | (if extern? 20 | llvm/CCallConv 21 | #_llvm/X86FastcallCallConv 22 | llvm/CCallConv 23 | #_llvm/FastCallConv)) 24 | (create-target-machine [this opts] 25 | (llvm/CreateTargetMachine (:target llvm-target) 26 | (str march "-" vendor "-" os) 27 | (or (x86-cpus/cpus (:cpu opts)) "generic") 28 | (or (:features opts) "") 29 | (or (target/code-gen-levels (:code-gen-level opts)) 30 | llvm/LLVMCodeGenLevelDefault) 31 | (or (target/reloc-modes (:reloc-mode opts)) 32 | llvm/LLVMRelocDefault) 33 | (or (target/code-models (:code-model opts)) 34 | llvm/LLVMCodeModelDefault))) 35 | (emit-to-file [this module opts] 36 | (let [tm (target/create-target-machine this opts) 37 | err (llvm/new-pointer) 38 | file (or (:filename opts) 39 | (llvm/temp-file "darwin_output" (case (:output-type opts) 40 | :asm ".s" 41 | :obj ".o" 42 | ".o")))] 43 | (when (llvm/TargetMachineEmitToFile tm 44 | module 45 | (name file) 46 | (or (target/output-types (:output-type opts)) 47 | llvm/LLVMAssemblyFile) 48 | err) 49 | (assert false (.getString (llvm/value-at err) 0))) 50 | (llvm/DisposeMessage (llvm/value-at err)) 51 | file)) 52 | (as-exe [this module opts] 53 | (let [f (target/emit-to-file this module (assoc (dissoc opts :filename) :output-type :asm)) 54 | cmds (list* "cc" f "-o" 55 | (or (:filename opts) 56 | "a.out") 57 | (:link-ops opts))] 58 | (when (:verbose opts) 59 | (println "Linking: " cmds)) 60 | (apply shell/sh cmds))) 61 | (as-dll [this module opts] 62 | (let [f (target/emit-to-file this module (assoc (dissoc opts :filename) :output-type :asm)) 63 | opts (merge {:filename (llvm/temp-file "darwin_dll" ".dylib")} 64 | opts) 65 | cmds (list* "cc" "-shared" f "-o" 66 | (:filename opts) 67 | (:link-ops opts))] 68 | (println cmds) 69 | (when (:verbose opts) 70 | (println "Linking: " cmds)) 71 | (apply shell/sh cmds) 72 | (reify clojure.lang.ILookup 73 | (valAt [this key] 74 | (.valAt this key nil)) 75 | (valAt [this key not-found] 76 | (let [nm (-> key :fn/name) 77 | _ (assert nm (str "Bad entity " key)) 78 | nfn (Function/getFunction (:filename opts) 79 | nm) 80 | mj-ret (-> key :fn/type :type.fn/return :node/type) 81 | rettype (case mj-ret 82 | :type/int Integer 83 | :type/pointer Pointer)] 84 | (fn [& args] 85 | (.invoke nfn rettype (to-array args))))))))) 86 | 87 | (defn get-march [] 88 | (System/getProperty "os.arch")) 89 | 90 | (defn get-vendor [] 91 | "apple") 92 | 93 | (defn get-os [] 94 | (let [r (shell/sh "uname" "-r")] 95 | (str "darwin" r))) 96 | 97 | (defn make-default-target [] 98 | (let [t (case (get-march) 99 | "x86_64" "x86-64" 100 | "x86" "x86")] 101 | (map->DarwinTarget 102 | {:march (get-march) 103 | :vendor (get-vendor) 104 | :os (get-os) 105 | :llvm-target (target/find-llvm-target-by-name t)}))) 106 | 107 | (defn init-target [register-fn] 108 | (llvm/InitializeX86TargetInfo) 109 | (llvm/InitializeX86Target) 110 | (llvm/InitializeX86TargetMC) 111 | (llvm/InitializeX86AsmPrinter) 112 | (llvm/InitializeX86AsmParser) 113 | (register-fn make-default-target)) 114 | -------------------------------------------------------------------------------- /src/mjolnir/targets/nvptx.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.targets.nvptx 2 | (:require 3 | [mjolnir.expressions :as expr] 4 | [mjolnir.targets.target :as target] 5 | [clojure.java.shell :as shell] 6 | [mjolnir.types :as types] 7 | [mjolnir.targets.nvptx-cpus :as nvptx-cpus] 8 | [mjolnir.llvmc :as llvm :refer [defnative]]) 9 | 10 | (:import [jcuda Pointer NativePointerObject] 11 | [jcuda.driver CUmodule JCudaDriver CUfunction CUdeviceptr CUdevice CUcontext])) 12 | 13 | (def allowed-char? (set "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_123456790")) 14 | 15 | (defn convert-to-char [x] 16 | (if (allowed-char? x) 17 | x 18 | (str "_" (.toUpperCase (Integer/toHexString (int x))) "_"))) 19 | 20 | (defn mangle-ptx [nm] 21 | (apply str (map convert-to-char nm))) 22 | 23 | (defn to-ptx-arg [a] 24 | (cond 25 | (float? a) (Pointer/to (float-array [a])) 26 | :else (Pointer/to (into-array NativePointerObject [a])))) 27 | 28 | (defn encode-args [args] 29 | (Pointer/to 30 | (into-array NativePointerObject 31 | (map 32 | to-ptx-arg 33 | args)))) 34 | 35 | 36 | (defn free [ptr] 37 | (JCudaDriver/cuMemFree ptr)) 38 | 39 | (defn to-float-array ^floats [ptr size] 40 | (let [arr (float-array size)] 41 | (JCudaDriver/cuMemcpyDtoH (Pointer/to arr) 42 | ptr 43 | (* size 4)) 44 | arr)) 45 | 46 | (defn to-float-array! [ptr size] 47 | (let [arr (to-float-array ptr size)] 48 | (free ptr) 49 | arr)) 50 | 51 | (defn device-alloc [size] 52 | (let [ptr (CUdeviceptr.)] 53 | (JCudaDriver/cuMemAlloc ptr size) 54 | ptr)) 55 | 56 | (defmacro cu [nm & args] 57 | (let [fname (symbol "JCudaDriver" (str "cu" nm))] 58 | `(let [r# (~fname ~@args)] 59 | (assert (= r# 0) (str "Cuda Call error " ~(name nm) " " r#)) 60 | r#))) 61 | 62 | 63 | (defrecord NVPTXTarget64 [march llvm-target] 64 | target/ITarget 65 | (pointer-type [this] 66 | (types/->IntegerType 64)) 67 | (default-address-space [this] 68 | 1) 69 | (get-calling-conv [this extern?] 70 | (if extern? 71 | llvm/PTXGlobal 72 | llvm/PTXDevice)) 73 | (create-target-machine [this opts] 74 | (llvm/CreateTargetMachine (:target llvm-target) 75 | "nvptx64-generic-generic" 76 | (or (nvptx-cpus/cpus (:cpu opts)) "sm_30") 77 | (or (:features opts) "sm_30") 78 | (or (target/code-gen-levels (:code-gen-level opts)) 79 | llvm/LLVMCodeGenLevelDefault) 80 | (or (target/reloc-modes (:reloc-mode opts)) 81 | llvm/LLVMRelocDefault) 82 | (or (target/code-models (:code-model opts)) 83 | llvm/LLVMCodeModelDefault))) 84 | (emit-to-file [this module opts] 85 | (let [tm (target/create-target-machine this opts) 86 | err (llvm/new-pointer) 87 | file (or (:filename opts) 88 | (llvm/temp-file "nvptx_output" (case (:output-type opts) 89 | :asm ".s" 90 | :obj ".ptx" 91 | ".ptx")))] 92 | (when (llvm/TargetMachineEmitToFile tm 93 | module 94 | (name file) 95 | (or (target/output-types (:output-type opts)) 96 | llvm/LLVMAssemblyFile) 97 | err) 98 | (assert false (.getString (llvm/value-at err) 0))) 99 | (llvm/DisposeMessage (llvm/value-at err)) 100 | file)) 101 | (as-dll [this module opts] 102 | (let [tm (target/create-target-machine this opts) 103 | err (llvm/new-pointer) 104 | file (or (:filename opts) 105 | (llvm/temp-file "nvptx_output" (case (:output-type opts) 106 | :asm ".s" 107 | :obj ".ptx" 108 | ".ptx"))) 109 | cumodule (CUmodule.)] 110 | (when (llvm/TargetMachineEmitToFile tm 111 | module 112 | (name file) 113 | (or (target/output-types (:output-type opts)) 114 | llvm/LLVMAssemblyFile) 115 | err) 116 | (assert false (.getString (llvm/value-at err) 0))) 117 | (llvm/DisposeMessage (llvm/value-at err)) 118 | (cu ModuleLoad cumodule file) 119 | (reify 120 | clojure.lang.ILookup 121 | (valAt [this k] 122 | (.valAt this k nil)) 123 | (valAt [this k el] 124 | (let [function (CUfunction.) 125 | nm (-> (k) :fn)] 126 | (println "finding" (mangle-ptx (:name nm))) 127 | (cu ModuleGetFunction function cumodule (mangle-ptx (:name nm))) 128 | (fn [[bx by bz] [gx gy gz]] 129 | (fn [& args] 130 | (let [args (encode-args args)] 131 | (cu LaunchKernel 132 | function 133 | (or gx 1) 134 | (or gy 1) 135 | (or gz 1) 136 | (or bx 1) 137 | (or by 1) 138 | (or bz 1) 139 | 0 nil 140 | args nil) 141 | (cu CtxSynchronize) 142 | args))))))))) 143 | 144 | 145 | (defnative Integer LLVMInitializeNVPTXTargetInfo) 146 | (defnative Integer LLVMInitializeNVPTXTarget) 147 | (defnative Integer LLVMInitializeNVPTXTargetMC) 148 | (defnative Integer LLVMInitializeNVPTXAsmPrinter) 149 | 150 | (defn make-default-target [] 151 | (map->NVPTXTarget64 152 | {:march "nvptx64" 153 | :llvm-target (target/find-llvm-target-by-name "nvptx64")})) 154 | 155 | (defn init-target [register-fn] 156 | (JCudaDriver/setExceptionsEnabled true) 157 | (cu Init 0) 158 | (let [a (int-array [0])] 159 | (cu DeviceGetCount a) 160 | (println "Number Of Devices: " (aget a 0) )) 161 | (let [device (CUdevice.) 162 | ctx (CUcontext.)] 163 | (JCudaDriver/cuDeviceGet device 0) 164 | (JCudaDriver/cuCtxCreate ctx 0 device)) 165 | (InitializeNVPTXTargetInfo) 166 | (InitializeNVPTXTarget) 167 | (InitializeNVPTXTargetMC) 168 | (InitializeNVPTXAsmPrinter) 169 | (register-fn make-default-target)) -------------------------------------------------------------------------------- /src/mjolnir/targets/nvptx_cpus.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.targets.nvptx-cpus) 2 | 3 | (def cpus 4 | {:sm-10 "sm_10" 5 | :sm-11 "sm_11" 6 | :sm-12 "sm_12" 7 | :sm-13 "sm_13" 8 | :sm-20 "sm_20" 9 | :sm-21 "sm_21" 10 | :sm-30 "sm_30" 11 | :sm-35 "sm_35"}) -------------------------------------------------------------------------------- /src/mjolnir/targets/nvptx_intrinsics.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.targets.nvptx-intrinsics 2 | (:require [mjolnir.expressions :as expr] 3 | [mjolnir.types :refer :all] 4 | [mjolnir.constructors-init :as const]) 5 | (:alias c mjolnir.constructors)) 6 | 7 | 8 | (c/defn ^{:exact "llvm.nvvm.read.ptx.sreg.tid.x"} ^:extern TID_X [-> Int32]) 9 | (c/defn ^{:exact "llvm.nvvm.read.ptx.sreg.tid.y"} ^:extern TID_Y [-> Int32]) 10 | (c/defn ^{:exact "llvm.nvvm.read.ptx.sreg.tid.z"} ^:extern TID_Z [-> Int32]) 11 | 12 | (c/defn ^{:exact "llvm.nvvm.read.ptx.sreg.ntid.x"} ^:extern NTID_X [-> Int32]) 13 | (c/defn ^{:exact "llvm.nvvm.read.ptx.sreg.ntid.y"} ^:extern NTID_Y [-> Int32]) 14 | (c/defn ^{:exact "llvm.nvvm.read.ptx.sreg.ntid.z"} ^:extern NTID_Z [-> Int32]) 15 | 16 | (c/defn ^{:exact "llvm.nvvm.read.ptx.sreg.ctaid.x"} ^:extern CTAID_X [-> Int32]) 17 | (c/defn ^{:exact "llvm.nvvm.read.ptx.sreg.ctaid.y"} ^:extern CTAID_Y [-> Int32]) 18 | (c/defn ^{:exact "llvm.nvvm.read.ptx.sreg.ctaid.z"} ^:extern CTAID_Z [-> Int32]) 19 | 20 | (c/defn ^{:exact "llvm.nvvm.read.ptx.sreg.nctaid.x"} ^:extern NCTAID_X [-> Int32]) 21 | (c/defn ^{:exact "llvm.nvvm.read.ptx.sreg.nctaid.y"} ^:extern NCTAID_Y [-> Int32]) 22 | (c/defn ^{:exact "llvm.nvvm.read.ptx.sreg.nctaid.z"} ^:extern NCTAID_Z [-> Int32]) 23 | 24 | (c/defn ^{:exact "llvm.nvvm.read.ptx.sreg.warpsize"} ^:extern WARPSIZE [-> Int32]) 25 | 26 | 27 | 28 | -------------------------------------------------------------------------------- /src/mjolnir/targets/target.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.targets.target 2 | (:require [mjolnir.llvmc :as llvm])) 3 | 4 | ;; The purpose of these protocols is to provide an abstract interface 5 | ;; by which a user can locate machine/os specific information and then 6 | ;; use that information to compile/assemble code 7 | 8 | 9 | 10 | (defprotocol ITarget 11 | (pointer-type [this] "Get the system pointer mjolnir type") 12 | (default-address-space [this] "Gets the default address space. Normally this is 0, it's 1 for PTX") 13 | (get-calling-conv [this extern?] "Returns the calling convention for a function. Could be different if not extern.") 14 | (create-target-machine [this opts] "Creates an llvm target machine from this target") 15 | (emit-to-file [this module opts] "Writes the module to a file with the specified options") 16 | (as-exe [this module opts] "Compiles the module as an executable") 17 | (as-dll [this module opts] "Compiles the module as a shared library")) 18 | 19 | (defn find-llvm-target-by-name [name] 20 | (first (filter (comp (partial = name) :name) 21 | (llvm/target-seq)))) 22 | 23 | 24 | (def code-gen-levels 25 | {:none llvm/LLVMCodeGenLevelNone 26 | :aggressive llvm/LLVMCodeGenLevelAggressive}) 27 | 28 | (def reloc-modes {}) 29 | 30 | (def code-models {}) 31 | 32 | (def output-types 33 | {:asm llvm/LLVMAssemblyFile 34 | :obj llvm/LLVMObjectFile}) 35 | 36 | 37 | 38 | 39 | -------------------------------------------------------------------------------- /src/mjolnir/targets/x86_cpus.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.targets.x86-cpus) 2 | 3 | (def cpus 4 | {:core-avx-i "core-avx-i" 5 | :haswell "haswell"}) -------------------------------------------------------------------------------- /src/mjolnir/types.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.types 2 | (:require [mjolnir.llvmc :as llvm] 3 | [mjolnir.config :refer :all] 4 | [mjolnir.ssa :refer :all] 5 | [mjolnir.targets.target :refer :all]) 6 | (:import [com.sun.jna Native Pointer])) 7 | 8 | 9 | (defmacro assure [pred] 10 | `(assert ~pred (str "at: " (pr-str (meta (:location ~'this))) 11 | " got: " (pr-str ~(second pred))))) 12 | 13 | (defmulti construct-expr (fn [type & more] type)) 14 | 15 | 16 | (defmacro validate-all [& body] 17 | `(apply valid? ~(vec body))) 18 | 19 | #_(defmacro assure-same-type [& body] 20 | `(reduce (fn [a# x#] 21 | (assert (= a# x#) 22 | (str "Expected same types, " 23 | "at: " (pr-str (meta (:location ~'this))) 24 | " got: " (pr-str ~(vec body)))))e 25 | ~(vec body))) 26 | 27 | (defmacro assure-same-type [& args] 28 | (identity 1)) 29 | 30 | (defprotocol Validatable 31 | (validate [this])) 32 | 33 | (defprotocol Type 34 | (llvm-type [this])) 35 | 36 | 37 | (defn valid? [tp] 38 | (validate tp) 39 | true) 40 | 41 | (defprotocol ElementPointer 42 | (etype [this])) 43 | 44 | (defprotocol ConstEncoder 45 | (encode-const [this val] "Encodes the value as a const with this type")) 46 | 47 | (defn ElementPointer? [t] 48 | (extends? ElementPointer (type t))) 49 | 50 | (defn type? [this] 51 | (extends? Type (type this))) 52 | 53 | (defn assure-type [tp] 54 | (assert (and (extends? Type (type tp)) 55 | (valid? tp)) 56 | (str "at: " (pr-str (meta (:location tp))) 57 | " got: " (pr-str tp)))) 58 | 59 | (defrecord IntegerType [width] 60 | IToPlan 61 | (add-to-plan [this] 62 | (gen-plan 63 | [this-id (singleton 64 | {:node/type :type/int 65 | :type/width width} 66 | this)] 67 | this-id))) 68 | 69 | (defrecord PlatformIntegerType [] 70 | IToPlan 71 | (add-to-plan [this] 72 | (add-to-plan *int-type*))) 73 | 74 | 75 | (defrecord VoidType [] 76 | Validatable 77 | (validate [this] 78 | true) 79 | Type 80 | (llvm-type [this] 81 | (llvm/VoidType)) 82 | IToPlan 83 | (add-to-plan [this] 84 | (gen-plan 85 | [this-id (singleton 86 | {:node/type :type/void})] 87 | this-id))) 88 | 89 | (defn integer-type? [tp] 90 | (instance? IntegerType tp)) 91 | 92 | (defrecord FloatType [width] 93 | Validatable 94 | (validate [this] 95 | (assure (integer? width))) 96 | Type 97 | (llvm-type [this] 98 | (case width 99 | 32 (llvm/FloatType) 100 | 64 (llvm/DoubleType))) 101 | ConstEncoder 102 | (encode-const [this val] 103 | (llvm/ConstReal (llvm-type this) val)) 104 | IToPlan 105 | (add-to-plan [this] 106 | (gen-plan 107 | [id (singleton 108 | {:node/type :type/float 109 | :type/width width} 110 | this)] 111 | id))) 112 | 113 | (defn float-type? [tp] 114 | (instance? FloatType tp)) 115 | 116 | (declare const-string-array) 117 | 118 | 119 | (defrecord PointerType [etype] 120 | IToPlan 121 | (add-to-plan [this] 122 | (gen-plan 123 | [tp (add-to-plan etype) 124 | this-id (singleton {:node/type :type/pointer 125 | :type/element-type tp} 126 | this)] 127 | this-id)) 128 | clojure.lang.IFn 129 | (invoke [this val] 130 | (construct-expr :->Cast this val))) 131 | 132 | 133 | 134 | 135 | (defn pointer-type? [tp] 136 | (instance? PointerType tp)) 137 | 138 | (defrecord VectorType [etype length] 139 | Validatable 140 | (validate [this] 141 | (assure-type etype) 142 | (assure (integer? length))) 143 | Type 144 | (llvm-type [this] 145 | (llvm/VectorType (llvm-type etype) length)) 146 | ElementPointer 147 | (etype [this] 148 | (:etype this)) 149 | ConstEncoder 150 | (encode-const [this val] 151 | (assert (= length (count val)) "Const must be the same length as the vector") 152 | (llvm/ConstVector (llvm/map-parr (partial encode-const etype) val) 153 | (count val)))) 154 | 155 | (defn vector-type? [tp] 156 | (instance? VectorType tp)) 157 | 158 | (defrecord ArrayType [etype cnt] 159 | Validatable 160 | (validate [this] 161 | (assure-type etype) 162 | (assure (integer? cnt))) 163 | Type 164 | (llvm-type [this] 165 | (llvm/ArrayType (llvm-type etype) cnt)) 166 | ElementPointer 167 | (etype [this] 168 | (:etype this)) 169 | IToPlan 170 | (add-to-plan [this] 171 | (gen-plan 172 | [tp (add-to-plan etype) 173 | this-id (singleton {:node/type :type/array 174 | :type/element-type tp 175 | :type/length cnt} 176 | this)] 177 | this-id))) 178 | 179 | (defrecord FunctionType [arg-types ret-type] 180 | Validatable 181 | (validate [this] 182 | (every? assure-type arg-types) 183 | (assure-type ret-type)) 184 | Type 185 | (llvm-type [this] 186 | (llvm/FunctionType (llvm-type ret-type) 187 | (llvm/map-parr llvm-type arg-types) 188 | (count arg-types) 189 | false)) 190 | IToPlan 191 | (add-to-plan [this] 192 | (gen-plan 193 | [args (add-all (map add-to-plan arg-types)) 194 | ret (add-to-plan ret-type) 195 | seq (assert-seq args) 196 | this-id (singleton (merge {:node/type :type/fn 197 | :type.fn/return ret} 198 | (when seq 199 | {:type.fn/arguments seq}))) 200 | _ (add-all (map (fn [x idx] 201 | (singleton {:fn.arg/type x 202 | :fn.arg/idx idx 203 | :fn.arg/fn this-id} 204 | nil)) 205 | args 206 | (range)))] 207 | this-id))) 208 | 209 | 210 | (comment 211 | (defn flatten-struct [tp] 212 | (->> (take-while (complement nil?) 213 | (iterate :extends tp)) 214 | reverse 215 | (mapcat :members)))) 216 | 217 | 218 | (defn flatten-struct [tp] 219 | (->> (take-while (complement nil?) 220 | (iterate :extends tp)) 221 | reverse 222 | (mapcat :members))) 223 | 224 | 225 | (defn seq-idx [col ksel k] 226 | (-> (zipmap (map ksel col) 227 | (range)) 228 | (get k))) 229 | 230 | (defn member-idx [struct member] 231 | (-> (flatten-struct struct) 232 | (seq-idx second member))) 233 | 234 | 235 | 236 | (defrecord StructType [name extends members] 237 | IToPlan 238 | (add-to-plan [this] 239 | (gen-plan 240 | [extends-id (if extends 241 | (add-to-plan extends) 242 | (no-op)) 243 | member-ids (->> (flatten-struct this) 244 | (map first) 245 | (map add-to-plan) 246 | add-all) 247 | struct-id (singleton (merge {:node/type :type/struct 248 | :type.struct/name name} 249 | (when extends-id 250 | {:type.struct/extends extends-id}))) 251 | members-idx (add-all (map 252 | (fn [id name idx] 253 | (singleton {:node/type :type/member 254 | :type.member/idx idx 255 | :type.member/name name 256 | :type.member/type id 257 | :type.member/struct struct-id})) 258 | member-ids 259 | (map second (flatten-struct this)) 260 | (range)))] 261 | struct-id))) 262 | 263 | (defn StructType? [tp] 264 | (instance? StructType tp)) 265 | 266 | (defn FunctionType? [tp] 267 | (instance? FunctionType tp)) 268 | 269 | 270 | (defn const-string-array [s] 271 | (let [ar (into-array Pointer (map #(llvm/ConstInt (llvm-type (->IntegerType 8)) % false) 272 | (concat s [0]))) 273 | llvm-ar (llvm/ConstArray (llvm-type (->IntegerType 8)) 274 | ar 275 | (count ar)) 276 | idx (into-array Pointer 277 | [(llvm/ConstInt (llvm-type (->IntegerType 64)) 0)]) 278 | gbl (llvm/AddGlobal *module* (llvm-type (->ArrayType (->IntegerType 8) 279 | (count ar)) ) 280 | (name (gensym "str_"))) 281 | casted (llvm/ConstBitCast gbl 282 | (llvm-type (->PointerType (->IntegerType 8))))] 283 | (llvm/SetInitializer gbl llvm-ar) 284 | casted)) 285 | 286 | 287 | 288 | ;; Common types 289 | (def Int32 (->IntegerType 32)) 290 | (def Int32* (->PointerType (->IntegerType 32))) 291 | (def Int64 (->IntegerType 64)) 292 | (def Int64* (->PointerType Int64)) 293 | (def Int1 (->IntegerType 1)) 294 | (def Int8 (->IntegerType 8)) 295 | (def I8* (->PointerType (->IntegerType 8))) 296 | (def Int8* (->PointerType (->IntegerType 8))) 297 | (def VoidT (->VoidType)) 298 | 299 | (def IntT (->PlatformIntegerType)) 300 | (def IntT* (->PointerType IntT)) 301 | 302 | (def Float32 (->FloatType 32)) 303 | (def Float32* (->PointerType Float32)) 304 | (def Float32x4 (->VectorType Float32 4)) 305 | (def Float64 (->FloatType 64)) 306 | (def Float64* (->PointerType Float64)) 307 | (def Float64x4 (->VectorType Float64 4)) 308 | (def Float64x4* (->PointerType Float64x4)) 309 | 310 | 311 | 312 | -------------------------------------------------------------------------------- /src/mjolnir/validation.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.validation 2 | (:require [mjolnir.ssa :as ssa] 3 | [mjolnir.ssa-rules :refer [rules]] 4 | [datomic.api :refer [q db] :as d])) 5 | 6 | 7 | (defn get-errors [db] 8 | (q '[:find ?id ?msg 9 | :in $ % 10 | :where 11 | (validate ?id ?msg)] 12 | db 13 | @rules)) 14 | 15 | (defn validate [db-val] 16 | (let [errors (get-errors db-val)] 17 | (assert (zero? (count (get-errors db-val))) 18 | (str "Errors: " (vec (for [[id msg] errors] 19 | [msg (d/touch (d/entity db-val id))])))))) -------------------------------------------------------------------------------- /test/mjolnir/simple_tests.clj: -------------------------------------------------------------------------------- 1 | (ns mjolnir.simple-tests 2 | (:require 3 | [mjolnir.inference :refer [infer-all]] 4 | [mjolnir.validation :refer [validate]] 5 | [clojure.test :refer :all] 6 | [datomic.api :refer [q db] :as d] 7 | [mjolnir.config :refer [*int-type* *target* default-target *float-type*]] 8 | [mjolnir.ssa :refer :all] 9 | [mjolnir.llvm-builder :refer :all] 10 | [mjolnir.types :refer [Int64 Int32 Float64 Float32 Float32* Float64* Int64* IntT 11 | ->FunctionType VoidT ->ArrayType ->PointerType]] 12 | [mjolnir.expressions :refer [->Fn ->Binop ->Arg ->If ->Call ->Gbl ->Cmp ->Let ->Local ->Loop ->Recur ->Free ->Malloc 13 | ->ASet ->AGet ->Do ->Module]] 14 | [mjolnir.constructors-init :refer [defnf]] 15 | [mjolnir.core :refer [to-db to-llvm-module build-default-module get-fn to-dll]]) 16 | (:alias c mjolnir.constructors)) 17 | 18 | 19 | (deftest compile-add-one-function 20 | (binding [*int-type* Int64 21 | *target* (default-target)] 22 | (let [conn (new-db) 23 | ft (->FunctionType [Int64] Int64) 24 | add-one (->Fn "add-one" ft ["a"] 25 | (->Binop :+ (->Arg 0) 1))] 26 | (-> (gen-plan 27 | [f-id (add-to-plan add-one)] 28 | f-id) 29 | (get-plan conn) 30 | commit) 31 | (dotimes [x 3] (infer-all conn)) 32 | (build (db conn))))) 33 | 34 | 35 | (deftest compile-fib-function 36 | (binding [*int-type* Int64 37 | *target* (default-target)] 38 | (let [conn (new-db) 39 | ft (->FunctionType [Int64] Int64) 40 | fib (->Fn "fib" ft ["x"] 41 | (->If (->Cmp :<= (->Arg 0) 1) 42 | (->Arg 0) 43 | (->Binop :+ 44 | (->Call (->Gbl "fib") 45 | [(->Binop :- (->Arg 0) 1)]) 46 | (->Call (->Gbl "fib") 47 | [(->Binop :- (->Arg 0) 2)]))))] 48 | (-> (gen-plan 49 | [f-id (add-to-plan fib)] 50 | f-id) 51 | (get-plan conn) 52 | commit) 53 | (dotimes [x 3] (infer-all conn)) 54 | (validate (db conn)) 55 | (let [x (build (db conn))] 56 | x)))) 57 | 58 | 59 | 60 | (deftest compile-let-function 61 | (binding [*int-type* Int64 62 | *target* (default-target)] 63 | (let [conn (new-db) 64 | ft (->FunctionType [Int64] Int64) 65 | fnc (->Fn "fib" ft ["x"] 66 | (->Let "foo" (->Arg 0) 67 | (->Local "foo")))] 68 | (-> (gen-plan 69 | [f-id (add-to-plan fnc)] 70 | f-id) 71 | (get-plan conn) 72 | commit) 73 | (dotimes [x 3] (infer-all conn)) 74 | (validate (db conn)) 75 | (let [x (build (db conn))] 76 | x)))) 77 | 78 | (deftest compile-count-to-ten-function 79 | (binding [*int-type* Int64 80 | *target* (default-target)] 81 | (let [conn (new-db) 82 | ft (->FunctionType [Int64] Int64) 83 | fnc (->Fn "fib" ft ["x"] 84 | (->Loop [["x" 10]] 85 | (->If (->Cmp :< (->Local "x") 10) 86 | (->Recur [(->Binop :+ (->Local "x") 1)]) 87 | (->Local "x"))))] 88 | (-> (gen-plan 89 | [f-id (add-to-plan fnc)] 90 | f-id) 91 | (get-plan conn) 92 | commit) 93 | (infer-all conn) 94 | (validate (db conn)) 95 | (let [x (build (db conn))] 96 | 97 | x)))) 98 | 99 | (deftest compile-aget-aset-function 100 | (binding [*int-type* Int64 101 | *target* (default-target)] 102 | (let [conn (new-db) 103 | ft (->FunctionType [] VoidT) 104 | atype (->ArrayType Int64 10) 105 | fnc (->Fn "fib" ft [] 106 | (->Let "arr" (->Malloc atype) 107 | (->Do 108 | [(->ASet (->Local "arr") 0 42) 109 | (->AGet (->Local "arr") 0) 110 | (->Free (->Local "arr"))])))] 111 | (-> (gen-plan 112 | [f-id (add-to-plan fnc)] 113 | f-id) 114 | (get-plan conn) 115 | commit) 116 | (infer-all conn) 117 | (validate (db conn)) 118 | (let [x (build (db conn))] 119 | x)))) 120 | 121 | (deftest compile-module 122 | (binding [*int-type* Int64 123 | *target* (default-target)] 124 | (let [conn (new-db) 125 | ft (->FunctionType [] VoidT) 126 | atype (->ArrayType Int64 10) 127 | fnc (->Fn "fnc1" ft [] 1) 128 | fnc2 (->Fn "fnc2" ft [] 2) 129 | mod (->Module [fnc fnc2])] 130 | (-> (gen-plan 131 | [f-id (add-to-plan mod)] 132 | f-id) 133 | (get-plan conn) 134 | commit) 135 | (infer-all conn) 136 | (validate (db conn)) 137 | (let [x (build (db conn))] 138 | x)))) 139 | 140 | 141 | (deftest compile-dotimes 142 | (binding [*int-type* Int64 143 | *target* (default-target)] 144 | (let [conn (new-db) 145 | ft (->FunctionType [Int64] Int64) 146 | fnc (->Fn "fib" ft ["x"] 147 | (c/if (c/= 1 2) 148 | (c/loop [x 42] 149 | 42) 150 | 42))] 151 | (-> (gen-plan 152 | [f-id (add-to-plan fnc)] 153 | f-id) 154 | (get-plan conn) 155 | commit) 156 | (infer-all conn) 157 | (validate (db conn)) 158 | (let [x (build (db conn))] 159 | (verify x) 160 | x)))) 161 | 162 | 163 | (defnf defnf-fib [Float64 x -> Float64] 164 | (if (< x 2.0) 165 | x 166 | (+ (::defnf-fib (- x 1.0)) 167 | (defnf-fib (- x 2.0))))) 168 | 169 | (deftest compile-constructors 170 | (binding [*int-type* Int64 171 | *float-type* Float64 172 | *target* (default-target)] 173 | (-> (c/module ['mjolnir.simple-tests/defnf-fib]) 174 | to-db 175 | to-llvm-module))) 176 | 177 | 178 | 179 | (defnf for-test [Float32 max -> Float32] 180 | (for [x [0.0 max 1.0]] 181 | 1.0) 182 | 1.0) 183 | 184 | (deftest for-tests 185 | (binding [*float-type* Float32 186 | *target* (default-target)] 187 | (-> (c/module ['mjolnir.simple-tests/for-test]) 188 | to-db 189 | to-llvm-module))) 190 | 191 | 192 | 193 | (c/defn for-max [Float32 xpx Float32 ypx Float32 max Float32 width Float32 height -> Float32] 194 | (c/for [x [0.0 max 1.0]] 195 | 1.0) 196 | 1.0) 197 | 198 | (deftest for-max 199 | (binding [*float-type* Float32 200 | *target* (default-target)] 201 | (-> (c/module ['mjolnir.simple-tests/for-max]) 202 | to-db 203 | to-llvm-module))) 204 | 205 | 206 | ;; Float math test - mandelbrot 207 | 208 | (defnf square [Float32 x -> Float32] 209 | (* x x)) 210 | 211 | (defnf calc-iteration [Float32 xpx Float32 ypx Float32 max Float32 width Float32 height -> Float32] 212 | (let [x0 (- (* (/ xpx width) 3.5) 2.5) 213 | y0 (- (/ (/ ypx height) 2.0) 1.0)] 214 | (loop [iteration 0.0 215 | x 0.0 216 | y 0.0] 217 | (if (and (< (+ (square x) 218 | (square y)) 219 | (square 2.0)) 220 | (< iteration max)) 221 | (recur (+ iteration 1.0) 222 | (+ (- (square x) 223 | (square y)) 224 | x0) 225 | (+ (* 2.0 x y) 226 | y0)) 227 | iteration)))) 228 | 229 | (defnf ^:extern calc-mandelbrot [Float32* arr Float32 width Float32 height Float32 max -> Float32*] 230 | (for [y [0.0 height 1.0]] 231 | (for [x [0.0 width 1.0]] 232 | (let [idx (cast Int64 (+ (* y width) x))] 233 | (aset arr idx (/ (calc-iteration x y max width height) max))))) 234 | arr) 235 | 236 | 237 | (deftest compile-mandelbrot 238 | (binding [*int-type* Int64 239 | *float-type* Float32 240 | *target* (default-target)] 241 | (-> (c/module ['mjolnir.simple-tests/square 242 | 'mjolnir.simple-tests/calc-iteration 243 | 'mjolnir.simple-tests/calc-mandelbrot]) 244 | to-db 245 | to-llvm-module))) 246 | 247 | (c/defstruct MyStruct 248 | :members [Int64 x 249 | Float64 y]) 250 | 251 | (def MyStruct* (->PointerType MyStruct)) 252 | 253 | (defnf struct-fn [MyStruct* foo -> Float64*] 254 | (set foo :x 42) 255 | (.-x foo) 256 | (Float64* foo)) 257 | 258 | (deftest compile-struct 259 | (binding [*int-type* Int64 260 | *float-type* Float32 261 | *target* (default-target)] 262 | (-> (c/module ['mjolnir.simple-tests/struct-fn]) 263 | to-db 264 | to-llvm-module))) 265 | 266 | (defnf test-dll [Int64 x -> Int64] 267 | (+ x 1)) 268 | 269 | 270 | #_(deftest compile-dll 271 | (let [mod (-> (c/module ['mjolnir.simple-tests/test-dll]) 272 | build-default-module 273 | to-dll) 274 | f (get-fn mod test-dll)] 275 | (is (= (f 42) 43)))) 276 | 277 | 278 | 279 | (defnf gc-test [IntT x -> Int64*] 280 | (:___init_GC___) 281 | (new IntT) 282 | (new IntT x)) 283 | 284 | (deftest compile-gc 285 | (let [mod (-> (c/module ['mjolnir.simple-tests/gc-test]) 286 | build-default-module)] 287 | (is true))) 288 | 289 | (defnf void-t [-> VoidT] 290 | 42) 291 | 292 | 293 | (defnf void-t-caller [-> Int64] 294 | (void-t) 295 | 42) 296 | 297 | #_(deftest compile-call-voidT 298 | (let [mod (-> (c/module ['mjolnir.simple-tests/void-t 299 | 'mjolnir.simple-tests/void-t-caller]) 300 | build-default-module)] 301 | (is true))) 302 | 303 | 304 | (c/defstruct A 305 | :members [Int64 x]) 306 | 307 | (def A* (->PointerType A)) 308 | 309 | (c/defstruct B 310 | :members [A* a]) 311 | 312 | (def B* (->PointerType B)) 313 | 314 | (defnf b-stuff [B* foo -> B*] 315 | foo) 316 | 317 | (deftest compile-call-voidT 318 | (let [mod (-> (c/module ['mjolnir.simple-tests/b-stuff]) 319 | build-default-module)] 320 | (is true))) 321 | 322 | 323 | 324 | 325 | (c/def counter Int64 0) 326 | 327 | (c/defn atomic-inc [-> Int64] 328 | (c/atomic counter :+ 1)) 329 | 330 | (deftest compile-atomic 331 | (let [mod (-> (c/module ['mjolnir.simple-tests/counter 332 | 'mjolnir.simple-tests/atomic-inc]) 333 | (build-default-module true) 334 | (to-dll))] 335 | (is true))) 336 | 337 | 338 | --------------------------------------------------------------------------------