├── .gitignore ├── NOTES ├── TODO ├── build.rkt ├── examples ├── compiler.rkt ├── hello-world.rkt ├── mandlebrot.rkt └── n-body.rkt ├── info.rkt ├── llvm-racket.cpp ├── llvm.scrbl ├── private ├── clang.rkt ├── ffi │ ├── all.rkt │ ├── arithmetic.rkt │ ├── basic-blocks.rkt │ ├── builder.rkt │ ├── cast.rkt │ ├── constants.rkt │ ├── ctypes.rkt │ ├── define.rkt │ ├── enums.rkt │ ├── functions.rkt │ ├── globals.rkt │ ├── instructions.rkt │ ├── intrinsics.rkt │ ├── lib.rkt │ ├── memory-buffers.rkt │ ├── memory.rkt │ ├── misc-instructions.rkt │ ├── misc-operations.rkt │ ├── module-io.rkt │ ├── modules.rkt │ ├── passes.rkt │ ├── paths.rkt │ ├── racket-ext.rkt │ ├── runtime.rkt │ ├── safe.rkt │ ├── terminators.rkt │ ├── types.rkt │ └── unsafe.rkt ├── llvm-config.rkt ├── llvm-headers.rkt ├── llvm-util-exptime.rkt ├── rename.rkt ├── safe │ └── structs.rkt ├── short.rkt ├── simple │ ├── aggregate.rkt │ ├── all.rkt │ ├── binop.rkt │ ├── builder.rkt │ ├── cast.rkt │ ├── comparison.rkt │ ├── convertible.rkt │ ├── extra.rkt │ ├── functions.rkt │ ├── generic.rkt │ ├── globals.rkt │ ├── indexed-types.rkt │ ├── intrinsics.rkt │ ├── memory.rkt │ ├── misc-instructions.rkt │ ├── modules.rkt │ ├── parameters.rkt │ ├── predicates.rkt │ ├── primitive-types.rkt │ ├── references.rkt │ ├── runtime.rkt │ ├── types.rkt │ ├── util.rkt │ └── values.rkt └── unsafe │ └── structs.rkt ├── safe.rkt ├── simple.rkt ├── tests └── tests.rkt └── unsafe.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | *.dylib 2 | *.dylib.dSYM 3 | *.so 4 | compiled 5 | doc 6 | -------------------------------------------------------------------------------- /NOTES: -------------------------------------------------------------------------------- 1 | Don't forget to build llvm with --enable-shared. -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | Move to racket/contract/base 2 | -------------------------------------------------------------------------------- /build.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require srfi/13 3 | dynext/compile 4 | dynext/link) 5 | 6 | (define (build) 7 | (define cxx-flags (llvm-config "--cxxflags")) 8 | (define ld-flags (llvm-config "--ldflags")) 9 | (define include-dirs (llvm-config "--includedir")) 10 | 11 | (define output-so-name 12 | (string-append "llvm-racket" 13 | (bytes->string/utf-8 (system-type 'so-suffix)))) 14 | 15 | ;; Switch the compiler to clang if we can find it. 16 | (parameterize ([current-extension-compiler 17 | (cond [(find-executable-path "clang") 18 | => values] 19 | [else 20 | (current-extension-compiler)])] 21 | 22 | ;; Change the compiler flags: 23 | [current-extension-compiler-flags 24 | (append cxx-flags (current-extension-compiler-flags))] 25 | 26 | ;; As well as the linker flags: 27 | [current-extension-linker-flags 28 | (append ld-flags (current-extension-linker-flags))]) 29 | 30 | 31 | ;; Finally, build: 32 | (compile-extension #t 33 | "llvm-racket.cpp" 34 | "llvm-racket.o" 35 | include-dirs) 36 | ;; ... and link: 37 | (link-extension #t 38 | (list "llvm-racket.o") 39 | output-so-name) 40 | 41 | ;; cleanup: 42 | (delete-file "llvm-racket.o") 43 | 44 | (void))) 45 | 46 | 47 | (define (llvm-config flags) 48 | (define (remove-blanks lst) 49 | (filter (lambda (x) (not (equal? x ""))) lst)) 50 | (remove-blanks 51 | (regexp-split " " 52 | (let-values (((process out in err) (subprocess #f #f #f "/usr/bin/env" "llvm-config" flags))) 53 | (begin0 54 | (string-trim-both (port->string out)) 55 | (close-output-port in) 56 | (close-input-port err) 57 | (close-input-port out) 58 | (subprocess-wait process) 59 | (unless (= (subprocess-status process) 0) (error 'llvm-config "Returned non zero exit code for flags: ~a" flags))))))) 60 | 61 | 62 | 63 | 64 | 65 | (build) 66 | ;rsync -r . ~/proj/racket/planet/llvm/1.0 67 | 68 | 69 | 70 | -------------------------------------------------------------------------------- /examples/compiler.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;Definitions 4 | ;Our language will be simple with two first class data types: 5 | ;Booleans and Integers (32Bit) 6 | ;There will also be first order functions 7 | ; 8 | ;The following expressions will be supported 9 | ;#t, #f, N where N is a numeric literal 10 | ;(if B T F) 11 | ;(binop X Y), where binop ∈ {+,-,x,/,%} 12 | ;(compare X Y), where compare ∈ {<,>,<=,>=,=} 13 | ;(let ((x expr) ...) body) 14 | ;(call fun arg-expr ...) 15 | ; 16 | ;A function definition will look like 17 | ;(define (fun-name arg ...) body) 18 | ; 19 | ;A program is something that looks like 20 | ;(program main-function-name 21 | ; function-definition ...) 22 | ; 23 | ; This implementation is not meant to be perfect and error check everything. 24 | ; It requires that the program be well-typed, for the obvious definition of 25 | ; well-typed. 26 | 27 | (require "../private/simple/all.rkt") 28 | 29 | ; Data for an expression 30 | (struct num-literal (value)) 31 | (struct bool-literal (value)) 32 | (struct identifier (symbol)) 33 | (struct conditional (test true false)) 34 | (struct binary-op (op left right)) 35 | (struct compare-op (op left right)) 36 | (struct binding (name expr)) 37 | (struct bind (bindings body)) 38 | (struct call (function args)) 39 | 40 | ; Data for a funciton definition 41 | (struct function-definition (name args body)) 42 | 43 | ; Data for a program 44 | (struct program (main functions)) 45 | 46 | (define (parse sexp) 47 | (define (binary-op-symbol? x) 48 | (member x '(+ - * / %))) 49 | (define (compare-op-symbol? x) 50 | (member x '(< > <= >= =))) 51 | (define (parse-program sexp) 52 | (match sexp 53 | (`(program ,(? symbol? main) ,funs ...) 54 | (program main (map parse-function funs))))) 55 | (define (parse-function sexp) 56 | (match sexp 57 | (`(define (,(? symbol? name) ,(? symbol? args) ...) ,body) 58 | (function-definition name args (parse-expression body))))) 59 | (define (parse-expression sexp) 60 | (match sexp 61 | ((? exact-integer? n) (num-literal n)) 62 | ((? boolean? v) (bool-literal v)) 63 | ((? symbol? v) (identifier v)) 64 | (`(if ,c ,t ,f) (conditional (parse-expression c) 65 | (parse-expression t) 66 | (parse-expression f))) 67 | (`(,(? binary-op-symbol? op) ,left ,right) 68 | (binary-op op (parse-expression left) (parse-expression right))) 69 | (`(,(? compare-op-symbol? op) ,left ,right) 70 | (compare-op op (parse-expression left) (parse-expression right))) 71 | (`(let ((,(? symbol? vars) ,exprs) ...) ,body) 72 | (bind (for/list ((v vars) (e exprs)) (binding v (parse-expression e))) 73 | (parse-expression body))) 74 | (`(call ,(? symbol? name) ,args ...) 75 | (call name (map parse-expression args))))) 76 | 77 | (parse-program sexp)) 78 | 79 | (define (compile program) 80 | (define context (llvm-create-context)) 81 | (define module (llvm-create-module "module" #:context context)) 82 | 83 | (enter-module/32 context module 84 | (define function-map 85 | (for/hash ((function (program-functions program))) 86 | (let ((name (function-definition-name function))) 87 | (values name 88 | (llvm-add-function 89 | (llvm-function-type* (llvm-int32-type) 90 | (for/list ((arg (function-definition-args function))) 91 | (llvm-int32-type))) 92 | (symbol->string (function-definition-name function))))))) 93 | 94 | (define (compile-function function) 95 | (match function 96 | ((function-definition name args body) 97 | (define llvm-function (hash-ref function-map name)) 98 | (llvm-set-position 99 | (llvm-add-block-to-function llvm-function #:name "entry")) 100 | (define base-env 101 | (for/hash ((arg args) (i (in-naturals))) 102 | (values arg (llvm-get-param i)))) 103 | (llvm-ret (compile-expression body base-env))))) 104 | 105 | (define (convert-binary-op op) 106 | (case op 107 | ((+) llvm-+) 108 | ((-) llvm--) 109 | ((*) llvm-*) 110 | ((/) llvm-/) 111 | ((%) llvm-i%))) 112 | (define (convert-compare-op op) 113 | (case op 114 | ((<) llvm-<) 115 | ((>) llvm->) 116 | ((<=) llvm-<=) 117 | ((>=) llvm->=) 118 | ((=) llvm-=))) 119 | 120 | (define (compile-expression expr env) 121 | (match expr 122 | ((num-literal n) (llvm-int n)) 123 | ((bool-literal b) (llvm-int (if b 1 0))) 124 | ((identifier s) (hash-ref env s)) 125 | ((binary-op op left right) 126 | ((convert-binary-op op) 127 | (compile-expression left env) 128 | (compile-expression right env))) 129 | ((compare-op op left right) 130 | ((convert-compare-op op) 131 | (compile-expression left env) 132 | (compile-expression right env))) 133 | ((conditional c t f) 134 | (llvm-if (llvm-/= 0 (compile-expression c env)) 135 | (compile-expression t env) 136 | (compile-expression f env))) 137 | ((bind bindings body) 138 | (let ((new-env (for/fold ((new-env env)) ((binding bindings)) 139 | (hash-set new-env (binding-name binding) 140 | (compile-expression (binding-expr binding)))))) 141 | (compile-expression body new-env))) 142 | ((call name args) 143 | (define function (hash-ref function-map name)) 144 | (define evaled-args 145 | (for/list ((arg args)) (compile-expression arg env))) 146 | (llvm-call* function evaled-args)))) 147 | 148 | (for ((function (program-functions program))) 149 | (compile-function function)) 150 | module)) 151 | 152 | 153 | 154 | (define program1 155 | '(program main 156 | (define (main) 2))) 157 | (define program2 158 | '(program main 159 | (define (main) (if #t 1 2)))) 160 | (define program3 161 | '(program main 162 | (define (main) (+ (call sub #t) (call sub #f))) 163 | (define (sub v) (if v 2 (* 3 (call sub #t)))))) 164 | 165 | (define program4 166 | '(program main 167 | (define (main) (call fact 5)) 168 | (define (fact x) 169 | (if (= x 0) 1 (* x (call fact (- x 1))))))) 170 | 171 | (compile (parse program1)) 172 | (compile (parse program2)) 173 | (compile (parse program3)) 174 | (compile (parse program4)) 175 | 176 | 177 | 178 | -------------------------------------------------------------------------------- /examples/hello-world.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../unsafe.rkt") 4 | 5 | (define context (LLVMContextCreate)) 6 | (define module (LLVMModuleCreateWithNameInContext "gcd-module" context)) 7 | (define int-type (LLVMInt32TypeInContext context)) 8 | (define fun-type1 (LLVMFunctionType int-type (list int-type int-type) false)) 9 | (define fun-type2 (LLVMFunctionType int-type (list int-type int-type int-type) false)) 10 | (define gcd-fun (LLVMAddFunction module "gcd" fun-type1)) 11 | (define mul-add-fun (LLVMAddFunction module "mul-add" fun-type2)) 12 | 13 | (let () 14 | (define x (LLVMGetParam mul-add-fun 0)) 15 | (define y (LLVMGetParam mul-add-fun 1)) 16 | (define z (LLVMGetParam mul-add-fun 2)) 17 | (define entry (LLVMAppendBasicBlockInContext context mul-add-fun "entry")) 18 | (define builder (LLVMCreateBuilderInContext context)) 19 | 20 | (LLVMSetValueName x "x") 21 | (LLVMSetValueName y "y") 22 | (LLVMSetValueName z "z") 23 | (LLVMPositionBuilderAtEnd builder entry) 24 | (let* ((a (LLVMBuildMul builder x y "a")) 25 | (b (LLVMBuildAdd builder z a "b"))) 26 | (LLVMBuildRet builder b)) 27 | 28 | (LLVMDisposeBuilder builder) 29 | ) 30 | 31 | #| 32 | unsigned gcd(unsigned x, unsigned y) { 33 | if(x == y) { 34 | return x; 35 | } else if(x < y) { 36 | return gcd(x, y - x); 37 | } else { 38 | return gcd(x - y, y); 39 | } 40 | } 41 | |# 42 | (let () 43 | (define x (LLVMGetParam gcd-fun 0)) 44 | (define y (LLVMGetParam gcd-fun 1)) 45 | (define test-zero-block 46 | (LLVMAppendBasicBlockInContext context gcd-fun "test-zero")) 47 | (define test-less-block 48 | (LLVMAppendBasicBlockInContext context gcd-fun "test-less")) 49 | (define zero-block 50 | (LLVMAppendBasicBlockInContext context gcd-fun "zero")) 51 | (define less-block 52 | (LLVMAppendBasicBlockInContext context gcd-fun "less")) 53 | (define greater-block 54 | (LLVMAppendBasicBlockInContext context gcd-fun "greater")) 55 | (define builder (LLVMCreateBuilderInContext context)) 56 | (define zero (LLVMConstInt int-type 0 false)) 57 | 58 | (LLVMSetValueName x "x") 59 | (LLVMSetValueName y "y") 60 | (LLVMPositionBuilderAtEnd builder test-zero-block) 61 | (let ((cond (LLVMBuildICmp builder 'LLVMIntEQ x zero "cond"))) 62 | (LLVMBuildCondBr builder cond zero-block test-less-block)) 63 | 64 | (LLVMPositionBuilderAtEnd builder test-less-block) 65 | (let ((cond (LLVMBuildICmp builder 'LLVMIntULT x y "cond"))) 66 | (LLVMBuildCondBr builder cond less-block greater-block)) 67 | 68 | (LLVMPositionBuilderAtEnd builder zero-block) 69 | (LLVMBuildRet builder y) 70 | (LLVMPositionBuilderAtEnd builder less-block) 71 | (let* ((z (LLVMBuildSub builder y x "z")) 72 | (ans (LLVMBuildCall builder gcd-fun (list x z) "ans"))) 73 | (LLVMBuildRet builder ans)) 74 | (LLVMPositionBuilderAtEnd builder greater-block) 75 | (let* ((z (LLVMBuildSub builder x y "z")) 76 | (ans (LLVMBuildCall builder gcd-fun (list y z) "ans"))) 77 | (LLVMBuildRet builder ans)) 78 | 79 | (LLVMDumpModule module) 80 | (LLVMDisposeBuilder builder) 81 | ) 82 | 83 | (let-values (((err) (LLVMVerifyModule module 'LLVMReturnStatusAction))) 84 | (when err 85 | (display err) (exit 1))) 86 | 87 | (define arg1 (LLVMCreateGenericValueOfInt int-type 4592 #t)) 88 | (define arg2 (LLVMCreateGenericValueOfInt int-type 60 #t)) 89 | (LLVMLinkInJIT) 90 | (define ee (LLVMCreateExecutionEngineForModule module)) 91 | 92 | (define output (LLVMRunFunction ee gcd-fun (list arg1 arg2))) 93 | (LLVMGenericValueToInt output #t) 94 | 95 | ;(LLVMWriteBitcodeToFile module "tmp") 96 | ;(define pass-manager (LLVMCreatePassManager)) 97 | 98 | -------------------------------------------------------------------------------- /examples/mandlebrot.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | ffi/unsafe 5 | racket/flonum 6 | racket/cmdline 7 | racket/fixnum 8 | racket/list 9 | "../simple.rkt" 10 | "../private/short.rkt") 11 | 12 | 13 | (define mandel-size 8) 14 | (define (mandel-vec type) (ll (vec type mandel-size))) 15 | 16 | (define N (command-line #:args (n) (string->number n))) 17 | (define N.0 (fx->fl N)) 18 | (define 2/N (fl/ 2.0 N.0)) 19 | (define LIMIT-SQR 4.0) 20 | (define ITERATIONS 50) 21 | 22 | 23 | (define (llvm-and-vector vector) 24 | (for/fold ((acc (llvm-int 1 (llvm-int1-type)))) 25 | ((i (llvm-get-vector-type-size (value->llvm-type vector)))) 26 | (llvm-and acc (llvm-extract-element vector i)))) 27 | 28 | (define (mandel-vector v) 29 | (llvm-vector* (build-list mandel-size (lambda (i) v)))) 30 | 31 | (ll 32 | (llvm-define-module module 33 | #:exports (calculate-row) 34 | 35 | 36 | (llvm-define-function calculate-row 37 | ((ci float) (crs (ptr (arr float))) (block (ptr (arr i8))) -> void) 38 | 39 | (for i 0 (< i N) (+ i 8) 40 | (define bits 41 | (append* 42 | (for/list ((j (in-range 0 8 mandel-size))) 43 | (let* ((crs2 (for/list ((k mandel-size)) 44 | (load (gep crs 0 (+ i (+ j k))))))) 45 | (let ((bits (call mandelbrot (llvm-vector* crs2) (mandel-vector ci)))) 46 | (for/list ((i mandel-size)) 47 | (llvm-extract-element bits i))))))) 48 | (store 49 | (for/fold ((ans (llvm-int 0 i8))) 50 | ((j 8) (b bits)) 51 | (or ans 52 | (<< (zext b i8) 53 | (llvm-int #,(- 7 j) i8)))) 54 | (gep block 0 (/ i 8)))) 55 | 56 | (return)) 57 | 58 | (llvm-define-function mandelbrot 59 | ((cr (mandel-vec float)) (ci (mandel-vec float)) -> (mandel-vec bool)) 60 | #:visibility 'hidden 61 | #:linkage 'private 62 | 63 | (define LIMIT (mandel-vector 4.0)) 64 | 65 | (define zr (llvm:reference (llvm:box (mandel-vector 0.0)))) 66 | (define zi (llvm:reference (llvm:box (mandel-vector 0.0)))) 67 | 68 | (define (compute-magnitude) 69 | (+ (* zr zr) (* zi zi))) 70 | 71 | (for i 0 (< i ITERATIONS) (+ i 1) 72 | (when (llvm-and-vector (> (compute-magnitude) LIMIT)) 73 | (return (mandel-vector #f))) 74 | (llvm:set-multiple (list zr zi) 75 | (+ (- (* zr zr) (* zi zi)) cr) 76 | (+ (* (mandel-vector 2.0) (* zr zi)) ci))) 77 | 78 | (return (< (compute-magnitude) LIMIT))))) 79 | 80 | 81 | (llvm-assert-module-valid module) 82 | (void (llvm:optimize-module module)) 83 | (define jit (llvm:create-jit module)) 84 | 85 | 86 | 87 | (define O (current-output-port)) 88 | 89 | 90 | 91 | (define Crs 92 | (let ([v (make-flvector N)]) 93 | (begin0 v 94 | (for ([x (in-range N)]) 95 | (flvector-set! v x (fl- (fl/ (fx->fl (fx* 2 x)) N.0) 1.5)))))) 96 | (define byte-array (make-bytes (ceiling (/ N 8)))) 97 | (define output-row (llvm:pointer->generic byte-array)) 98 | (define gen-Crs (llvm:pointer->generic (flvector->cpointer Crs))) 99 | (define calc-row (llvm:extract-function jit calculate-row)) 100 | 101 | 102 | (fprintf O "P4\n~a ~a\n" N N) 103 | (let loop-y ([y N]) 104 | (let ([Ci (fl- (fl* 2/N (fx->fl y)) 1.0)]) 105 | (let ((gen-Ci (llvm:double->generic Ci))) 106 | (calc-row gen-Ci gen-Crs output-row) 107 | (write-bytes byte-array O) 108 | (when (fx> y 1) (loop-y (fx- y 1)))))) 109 | 110 | -------------------------------------------------------------------------------- /examples/n-body.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; The Computer Language Benchmarks Game 4 | ;; http://shootout.alioth.debian.org/ 5 | ;; 6 | ;; Imperative-style implementation based on the SBCL implementation by 7 | ;; Patrick Frankenberger and Juho Snellman, but using only native Scheme 8 | ;; idioms like 'named let' and 'do' special form. 9 | ;; 10 | ;; Contributed by Anthony Borla, then converted for Racket 11 | ;; by Matthew Flatt and Brent Fulgham 12 | ;; Converted to use LLVM Library by Eric Dobson 13 | 14 | #| 15 | Correct output N = 1000 is 16 | 17 | -0.169075164 18 | -0.169087605 19 | |# 20 | 21 | (require 22 | racket/cmdline 23 | racket/flonum 24 | (for-syntax racket/base) 25 | "../simple.rkt" 26 | "../private/ffi/safe.rkt" 27 | "../private/simple/parameters.rkt" 28 | "../private/short.rkt" 29 | (only-in ffi/unsafe 30 | _double 31 | cblock->vector)) 32 | 33 | ;; ------------------------------ 34 | ;; define planetary masses, initial positions & velocity 35 | 36 | (define +pi+ 3.141592653589793) 37 | (define +days-per-year+ 365.24) 38 | 39 | (define +solar-mass+ (* 4 +pi+ +pi+)) 40 | 41 | (define +dt+ 0.01) 42 | 43 | (ll 44 | (llvm-define-module module 45 | #:exports (offset-momentum energy advance advance-n) 46 | 47 | (llvm-define-struct body ((position (vec float 3)) 48 | (velocity (vec float 3)) 49 | (mass float)) #:omit-constructor) 50 | 51 | (define (make-body x y z vx vy vz mass) 52 | (llvm-struct (llvm-vector x y z) (llvm-vector vx vy vz) mass)) 53 | 54 | 55 | (define (set-body-position! planet val) 56 | (store val (gep0 planet 0))) 57 | (define (set-body-velocity! planet val) 58 | (store val (gep0 planet 1))) 59 | 60 | 61 | (define sun-initial 62 | (make-body 0.0 0.0 0.0 0.0 0.0 0.0 +solar-mass+)) 63 | 64 | (define jupiter-initial 65 | (make-body 4.84143144246472090 66 | -1.16032004402742839 67 | -1.03622044471123109e-1 68 | (* 1.66007664274403694e-3 +days-per-year+) 69 | (* 7.69901118419740425e-3 +days-per-year+) 70 | (* -6.90460016972063023e-5 +days-per-year+) 71 | (* 9.54791938424326609e-4 +solar-mass+))) 72 | 73 | (define saturn-initial 74 | (make-body 8.34336671824457987 75 | 4.12479856412430479 76 | -4.03523417114321381e-1 77 | (* -2.76742510726862411e-3 +days-per-year+) 78 | (* 4.99852801234917238e-3 +days-per-year+) 79 | (* 2.30417297573763929e-5 +days-per-year+) 80 | (* 2.85885980666130812e-4 +solar-mass+))) 81 | 82 | (define uranus-initial 83 | (make-body 1.28943695621391310e1 84 | -1.51111514016986312e1 85 | -2.23307578892655734e-1 86 | (* 2.96460137564761618e-03 +days-per-year+) 87 | (* 2.37847173959480950e-03 +days-per-year+) 88 | (* -2.96589568540237556e-05 +days-per-year+) 89 | (* 4.36624404335156298e-05 +solar-mass+))) 90 | 91 | (define neptune-initial 92 | (make-body 1.53796971148509165e+01 93 | -2.59193146099879641e+01 94 | 1.79258772950371181e-01 95 | (* 2.68067772490389322e-03 +days-per-year+) 96 | (* 1.62824170038242295e-03 +days-per-year+) 97 | (* -9.51592254519715870e-05 +days-per-year+) 98 | (* 5.15138902046611451e-05 +solar-mass+))) 99 | 100 | (define size-of-system 5) 101 | 102 | (llvm-define-global system-global 103 | (llvm-constant-array 104 | sun-initial 105 | jupiter-initial 106 | saturn-initial 107 | uranus-initial 108 | neptune-initial)) 109 | (define system (llvm:reference system-global)) 110 | (define sun (ger0 system 0)) 111 | 112 | (define (vector3 x) 113 | (llvm-vector x x x)) 114 | (define (size v) 115 | (let ((v2 (* v v))) 116 | (+ (llvm-extract-element v2 0) 117 | (+ (llvm-extract-element v2 1) 118 | (llvm-extract-element v2 2))))) 119 | (define (+= ref value) 120 | (set ref (+ ref value))) 121 | (define (-= ref value) 122 | (set ref (- ref value))) 123 | 124 | 125 | 126 | (llvm-define-function offset-momentum 127 | (-> void) 128 | (define center (llvm:reference (llvm:box (vector3 0.0)))) 129 | 130 | (for index 0 (< index size-of-system) (+ 1 index) 131 | (let ((planet (ger0 system index))) 132 | (+= center (* (body-velocity planet) 133 | (vector3 (body-mass planet)))))) 134 | 135 | (set (body&-velocity sun) 136 | (/ (- (vector3 0.0) center) 137 | (vector3 +solar-mass+))) 138 | (return)) 139 | 140 | 141 | (llvm-define-function energy 142 | (-> float) 143 | (define e (llvm:reference (llvm:box 0.0))) 144 | 145 | (for index 0 (< index size-of-system) (+ 1 index) 146 | (let ((planet (ger0 system index))) 147 | (+= e (* 0.5 148 | (* (body-mass planet) 149 | (size (body-velocity planet))))) 150 | (for other-index (+ 1 index) (< other-index size-of-system) (+ 1 other-index) 151 | (let* ((other-planet (ger0 system other-index)) 152 | (dpos (- (body-position planet) (body-position other-planet))) 153 | (dist (sqrt (size dpos)))) 154 | (-= e (/ (* (body-mass planet) 155 | (body-mass other-planet)) 156 | dist)))))) 157 | (return e)) 158 | 159 | 160 | (llvm-define-function advance-n 161 | ((n int) -> void) 162 | (for index 0 (< index n) (+ 1 index) 163 | (call advance)) 164 | (return)) 165 | 166 | (llvm-define-function advance 167 | (-> void) 168 | #:visibility 'hidden 169 | #:linkage 'private 170 | 171 | 172 | (for* ((index size-of-system)) 173 | (let* ((outer-planet (ger0 system index)) 174 | (outer-pos (body&-position outer-planet)) 175 | (outer-mass (body&-mass outer-planet))) 176 | (define vel (llvm:reference (llvm:box (body&-velocity outer-planet)))) 177 | (for inner-index (+ 1 index) (< inner-index size-of-system) (+ 1 inner-index) 178 | (let* ((inner-planet (ger0 system inner-index)) 179 | (dpos (- outer-pos (body&-position inner-planet))) 180 | (dist2 (size dpos)) 181 | (mag (/ +dt+ (* dist2 (sqrt dist2)))) 182 | (dpos-mag (* dpos (vector3 mag))) 183 | (inner-mass (body&-mass inner-planet))) 184 | (-= vel (* dpos-mag (vector3 inner-mass))) 185 | (set (body&-velocity inner-planet) 186 | (+ (body&-velocity inner-planet) 187 | (* dpos-mag (vector3 outer-mass)))))) 188 | ;End of inner loop 189 | (set (body&-velocity outer-planet) vel) 190 | (set (body&-position outer-planet) (+ outer-pos (* (vector3 +dt+) vel))))) 191 | (return)) 192 | 193 | 194 | 195 | )) 196 | 197 | 198 | ;(display (llvm-module-description module)) 199 | (llvm-assert-module-valid module) 200 | (void (llvm:optimize-module module)) 201 | ;(display (llvm-module-description module)) 202 | (define jit (llvm:create-jit module)) 203 | (define new-offset-momentum (llvm:extract-function jit offset-momentum)) 204 | (define new-energy (llvm:extract-function jit energy)) 205 | (define new-advance-n (llvm:extract-function jit advance-n)) 206 | 207 | (let ([n (command-line #:args (n) (string->number n))]) 208 | (new-offset-momentum) 209 | (printf "~a\n" (real->decimal-string (llvm:generic->double (new-energy)) 9)) 210 | (new-advance-n (llvm:int32->generic n)) 211 | (printf "~a\n" (real->decimal-string (llvm:generic->double (new-energy)) 9))) 212 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | (define name "llvm") 3 | (define primary-file "safe.rkt") 4 | (define categories '(devtools)) 5 | (define scribblings '(("llvm.scrbl" ()))) 6 | -------------------------------------------------------------------------------- /llvm-racket.cpp: -------------------------------------------------------------------------------- 1 | #include "llvm-c/Core.h" 2 | #include "llvm/IR/Type.h" 3 | #include "llvm/IR/Value.h" 4 | #include "llvm/PassManager.h" 5 | //#include "llvm/IntrinsicInst.h" 6 | #include "llvm/Support/TargetSelect.h" 7 | #include "llvm/Support/raw_ostream.h" 8 | #include "llvm/Target/TargetLibraryInfo.h" 9 | #include "llvm/IR/DataLayout.h" 10 | #include "llvm/IR/Intrinsics.h" 11 | #include "llvm/IR/Module.h" 12 | #include "llvm/IR/Verifier.h" 13 | #include "llvm/Transforms/IPO.h" 14 | #include "llvm/Transforms/IPO/PassManagerBuilder.h" 15 | #include "llvm/ADT/Triple.h" 16 | 17 | 18 | #ifdef __cplusplus 19 | 20 | extern "C" { 21 | #endif 22 | 23 | using namespace llvm; 24 | 25 | 26 | /*===-- Error handling ----------------------------------------------------===*/ 27 | 28 | const char* LLVMGetTypeDescription(LLVMTypeRef Ty) { 29 | std::string DescStr; 30 | raw_string_ostream DescOS(DescStr); 31 | unwrap(Ty)->print(DescOS); 32 | std::string str = DescOS.str(); 33 | char* cstr = (char*) malloc(str.length()+1); 34 | strcpy(cstr,str.c_str()); 35 | return cstr; 36 | } 37 | 38 | char* LLVMGetValueDescription(LLVMValueRef V) { 39 | std::string DescStr; 40 | raw_string_ostream DescOS(DescStr); 41 | unwrap(V)->print(DescOS); 42 | std::string str = DescOS.str(); 43 | char* cstr = (char*) malloc(str.length()+1); 44 | strcpy(cstr,str.c_str()); 45 | 46 | return cstr; 47 | } 48 | 49 | 50 | char* LLVMGetModuleDescription(LLVMModuleRef M) { 51 | std::string DescStr; 52 | raw_string_ostream DescOS(DescStr); 53 | unwrap(M)->print(DescOS,NULL); 54 | std::string str = DescOS.str(); 55 | char* cstr = (char*) malloc(str.length()+1); 56 | strcpy(cstr,str.c_str()); 57 | 58 | return cstr; 59 | } 60 | 61 | 62 | bool LLVMIsValidTypeIndex(LLVMTypeRef Ty, LLVMValueRef Idx) { 63 | CompositeType* Comp = cast(unwrap(Ty)); 64 | const Value* V = unwrap(Idx); 65 | return Comp->indexValid(V); 66 | } 67 | 68 | LLVMTypeRef LLVMGetTypeAtIndex(LLVMTypeRef Ty, LLVMValueRef Idx) { 69 | CompositeType* Comp = cast(unwrap(Ty)); 70 | const Value* V = unwrap(Idx); 71 | return wrap(Comp->getTypeAtIndex(V)); 72 | } 73 | 74 | bool LLVMIsTerminatorInstruction(LLVMValueRef V) { 75 | return cast(unwrap(V))->isTerminator(); 76 | } 77 | 78 | void LLVMInitializeRacket() { 79 | InitializeNativeTarget(); 80 | } 81 | 82 | bool LLVMOptimizeModule(LLVMModuleRef Mod) { 83 | Module* M = unwrap(Mod); 84 | 85 | // Create a PassManager to hold and optimize the collection of passes we are 86 | // about to build. 87 | PassManager Passes; 88 | 89 | // Add an appropriate TargetLibraryInfo pass for the module's triple. 90 | TargetLibraryInfo *TLI = new TargetLibraryInfo(Triple(M->getTargetTriple())); 91 | 92 | // Add an appropriate DataLayout instance for this module. 93 | // const std::string &ModuleDataLayout = M->getDataLayout(); 94 | // if (!ModuleDataLayout.empty()) { 95 | // DataLayout *TD = NULL; // new DataLayout(ModuleDataLayout); 96 | // Passes.add(TD); 97 | // } 98 | 99 | 100 | Passes.add(createVerifierPass()); // Verify that input is correct 101 | 102 | // -std-compile-opts adds the same module passes as -O3. 103 | PassManagerBuilder Builder; 104 | Builder.Inliner = createFunctionInliningPass(); 105 | Builder.OptLevel = 3; 106 | Builder.populateModulePassManager(Passes); 107 | 108 | 109 | // Now that we have all of the passes ready, run them. 110 | bool change = Passes.run(*M); 111 | 112 | return change; 113 | } 114 | 115 | 116 | LLVMValueRef LLVMGetIntrinsic( 117 | LLVMModuleRef M, 118 | Intrinsic::ID id, 119 | LLVMTypeRef *ParamTypes, 120 | unsigned ParamCount) { 121 | 122 | ArrayRef Tys(unwrap(ParamTypes), ParamCount); 123 | return wrap(Intrinsic::getDeclaration(unwrap(M), id, Tys)); 124 | } 125 | 126 | 127 | 128 | #ifdef __cplusplus 129 | } 130 | 131 | #endif /* !defined(__cplusplus) */ 132 | -------------------------------------------------------------------------------- /llvm.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @title{LLVM} 4 | 5 | This is the start of the documentation for the Racket bindings to the LLVM API. 6 | 7 | There are currently two version of the API; Safe and Unsafe. Through the Safe API 8 | all memory managment of the LLVM objects and does not allow improper use of the API. 9 | The Unsafe API puts memory management in the users hands and may not catch all 10 | improper uses of the API. This may lead to corrupted memory or segfaults; 11 | You have been warnedis done. 12 | 13 | On top of the safe API is the Simple API. The Safe API is just a wrapper around 14 | the C API that checks for correct usage, the Simple API on the other hand does 15 | conversions and is intended to be more Racket-like. 16 | 17 | 18 | @section{Simple} 19 | 20 | The 21 | -------------------------------------------------------------------------------- /private/clang.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require ffi/unsafe racket/format racket/list ffi/unsafe/alloc) 4 | (require "llvm-config.rkt") 5 | (provide 6 | create-index 7 | index? 8 | create-translation-unit-from-source-file 9 | translation-unit? 10 | translation-unit-cursor 11 | cursor? 12 | cursor-map 13 | cursor-spelling 14 | cursor-find 15 | 16 | enum-constant-decl-value 17 | namespace-decl-cursor? 18 | enum-decl-cursor? 19 | typedef-decl-cursor?) 20 | 21 | (define lib-clang (ffi-lib (build-path (llvm-lib-dir) "libclang"))) 22 | 23 | ;; Without this clang installs signal handlers that mess up the racket VM 24 | (void (putenv "LIBCLANG_DISABLE_CRASH_RECOVERY" "")) 25 | 26 | ;; Indices 27 | (struct index (pointer)) 28 | 29 | (define _index 30 | (make-ctype _pointer 31 | index-pointer 32 | (λ (v) (error '_index "Conversion not supported")))) 33 | 34 | (define create-index 35 | (let () 36 | (define dispose-index 37 | (get-ffi-obj "clang_disposeIndex" lib-clang (_fun _pointer -> _void))) 38 | (define create-index 39 | ((allocator dispose-index) 40 | (get-ffi-obj "clang_createIndex" lib-clang (_fun _bool _bool -> _pointer))) ) 41 | 42 | (lambda (#:exclude-declarations-from-pch [exclude #f] #:display-diagnostics [diagnostics #f]) 43 | (index (create-index exclude diagnostics))))) 44 | 45 | ;; String functions 46 | (define _CXString 47 | (let () 48 | (define-cstruct _CXString 49 | ([data _pointer] 50 | [flags _uint])) 51 | 52 | (define get-cstring 53 | (get-ffi-obj "clang_getCString" lib-clang 54 | (_fun _CXString -> _string))) 55 | 56 | (define dispose-string 57 | (get-ffi-obj "clang_disposeString" lib-clang 58 | (_fun _CXString -> _void))) 59 | (make-ctype _CXString 60 | (λ (v) (error '_CXString "Conversion not supported")) 61 | (λ (v) 62 | (begin0 63 | (get-cstring v) 64 | (dispose-string v)))))) 65 | 66 | ;; Translation units 67 | (struct translation-unit (owner pointer)) 68 | (define _translation-unit 69 | (make-ctype _pointer 70 | translation-unit-pointer 71 | (λ (v) (error '_CXTranslationUnit "Conversion not supported")))) 72 | 73 | (define create-translation-unit-from-source-file 74 | (let () 75 | (define dispose-translation-unit 76 | (get-ffi-obj "clang_disposeTranslationUnit" lib-clang (_fun _pointer -> _void))) 77 | (define create-translation-unit-from-source-file 78 | ((allocator dispose-translation-unit) 79 | (get-ffi-obj "clang_createTranslationUnitFromSourceFile" lib-clang 80 | (_fun (index source-file-name flags unsaved-files) :: 81 | (index : _index) (source-file-name : _string) 82 | (_int = (length flags)) (flags : (_list i _string)) 83 | (_int = (length unsaved-files)) (unsaved-files : (_list i _pointer)) 84 | -> _pointer)))) 85 | 86 | (lambda (index source-file [flags '()] [unsaved-files '()]) 87 | (translation-unit 88 | index 89 | (create-translation-unit-from-source-file index source-file flags unsaved-files))))) 90 | 91 | 92 | ;; Cursors 93 | (define _CXCursorKind _uint) 94 | (define-cstruct _CXCursor 95 | ([kind _CXCursorKind] 96 | [xdata _int] 97 | [data (_array _pointer 3)])) 98 | 99 | (struct cursor (owner struct)) 100 | (define _cursor 101 | (make-ctype _CXCursor 102 | cursor-struct 103 | (λ (v) (error '_cursor "Conversion not supported")))) 104 | 105 | ;; Cursor constructor 106 | (define translation-unit-cursor 107 | (get-ffi-obj "clang_getTranslationUnitCursor" lib-clang 108 | (_fun (tu : _translation-unit) 109 | -> (c : _CXCursor) 110 | -> (cursor tu c)))) 111 | 112 | ;; Cursor traversal 113 | (define _CXChildVisitResult 114 | (_enum 115 | '(CXChildVisit_Break 116 | CXChildVisit_Continue 117 | CXChildVisit_Recurse))) 118 | (define _CXClientData _pointer) 119 | (define _CXCursorVisitor 120 | (_fun _CXCursor _CXCursor _CXClientData -> _CXChildVisitResult)) 121 | 122 | 123 | (define cursor-visit-children 124 | (get-ffi-obj "clang_visitChildren" lib-clang 125 | (_fun _cursor _CXCursorVisitor _CXClientData -> _bool))) 126 | 127 | ;; Cursor Accessors 128 | (define cursor-spelling 129 | (get-ffi-obj "clang_getCursorSpelling" lib-clang 130 | (_fun _cursor -> _CXString))) 131 | (define enum-constant-decl-value 132 | (get-ffi-obj "clang_getEnumConstantDeclValue" lib-clang 133 | (_fun _cursor -> _uint))) 134 | 135 | ;; Cursor helpers 136 | (define (enum-decl-cursor? cursor) 137 | (equal? (CXCursor-kind (cursor-struct cursor)) 5)) 138 | (define (typedef-decl-cursor? cursor) 139 | (equal? (CXCursor-kind (cursor-struct cursor)) 20)) 140 | (define (namespace-decl-cursor? cursor) 141 | (equal? (CXCursor-kind (cursor-struct cursor)) 22)) 142 | 143 | 144 | 145 | ;; Folds over cursor-visit-children 146 | (define (cursor-fold c f init) 147 | (define acc (malloc-immobile-cell init)) 148 | (cursor-visit-children c 149 | (λ (child parent data) 150 | (define new-child (cursor (cursor-owner c) child)) 151 | 152 | (ptr-set! data _racket (f new-child (ptr-ref data _racket))) 153 | 'CXChildVisit_Continue) 154 | acc) 155 | (begin0 156 | (ptr-ref acc _racket) 157 | (free-immobile-cell acc))) 158 | 159 | (define (cursor-map c f) 160 | (reverse 161 | (cursor-fold c 162 | (λ (c acc) (cons (f c) acc)) 163 | null))) 164 | 165 | (define (cursor-find c f) 166 | (define acc (malloc-immobile-cell #f)) 167 | (and 168 | (cursor-visit-children c 169 | (λ (child parent data) 170 | (define new-child (cursor (cursor-owner c) child)) 171 | (define v (f new-child)) 172 | (cond 173 | [v 174 | (ptr-set! data _racket v) 175 | 'CXChildVisit_Break] 176 | [else 'CXChildVisit_Continue])) 177 | acc) 178 | (begin0 179 | (ptr-ref acc _racket) 180 | (free-immobile-cell acc)))) 181 | 182 | #| 183 | (define idx (create-index)) 184 | 185 | ;(define tu (create-translation-unit-from-source-file idx "/Users/endobson/tmp/clang/tmp.c")) 186 | (define tu (create-translation-unit-from-source-file idx 187 | (string-append (llvm-include-dir) "/clang-c/Index.h"))) 188 | 189 | (define cursor (translation-unit-cursor tu)) 190 | 191 | (define (enum-decl->_enum cursor) 192 | (_enum 193 | (cursor-map cursor 194 | (λ (child) 195 | (list (cursor-spelling child) (enum-constant-decl-value child)))))) 196 | 197 | (filter values 198 | (cursor-map cursor 199 | (λ (cursor) 200 | (cond 201 | [(typedef-decl-kind? (CXCursor-kind cursor)) 202 | (define enum (cursor-find cursor enum-decl->_enum)) 203 | (and enum (list 'typedef (cursor-spelling cursor) enum))] 204 | [(enum-decl-kind? (CXCursor-kind cursor)) 205 | (define name (cursor-spelling cursor)) 206 | (and (not (equal? "" name)) 207 | (list 'enum name (enum-decl->_enum cursor)))] 208 | [else #f])))) 209 | 210 | |# 211 | -------------------------------------------------------------------------------- /private/ffi/all.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (define-syntax-rule (reprovide path ...) 5 | (begin 6 | (require path ...) 7 | (provide (all-from-out path ...)))) 8 | 9 | (reprovide 10 | "arithmetic.rkt" 11 | "basic-blocks.rkt" 12 | "builder.rkt" 13 | "cast.rkt" 14 | "constants.rkt" 15 | "functions.rkt" 16 | "globals.rkt" 17 | "instructions.rkt" 18 | "intrinsics.rkt" 19 | "memory-buffers.rkt" 20 | "memory.rkt" 21 | "misc-instructions.rkt" 22 | "misc-operations.rkt" 23 | "module-io.rkt" 24 | "modules.rkt" 25 | "passes.rkt" 26 | "racket-ext.rkt" 27 | "runtime.rkt" 28 | "terminators.rkt" 29 | "types.rkt") 30 | 31 | -------------------------------------------------------------------------------- /private/ffi/arithmetic.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "enums.rkt" 5 | "define.rkt" 6 | "misc-operations.rkt" 7 | "ctypes.rkt") 8 | 9 | (require ffi/unsafe) 10 | 11 | 12 | ;TODO differentiate types and ensure that types match, 13 | ;and contexts match 14 | (define safe:binop 15 | (_fun (builder : safe:LLVMBuilderRef) 16 | safe:LLVMValueRef 17 | safe:LLVMValueRef 18 | _non-null-string -> 19 | (ptr : _pointer) -> 20 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 21 | 22 | (define (safe:llvm-value-for-builder/c builder) 23 | (and/c 24 | safe:llvm-value-ref? 25 | (lambda (v) 26 | (let ((owner (safe:llvm-value-ref-owner v))) 27 | (if (safe:llvm-module-ref? owner) 28 | (equal? owner (safe:llvm-builder-ref-module builder)) 29 | (equal? owner (safe:llvm-module-ref-context 30 | (safe:llvm-builder-ref-module builder)))))))) 31 | 32 | 33 | (define safe:binop/c 34 | (->i ((builder safe:llvm-builder-ref?) 35 | (left-value (builder) (safe:llvm-value-for-builder/c builder)) 36 | (right-value (builder) (safe:llvm-value-for-builder/c builder)) 37 | (name string?)) 38 | #:pre/name (left-value right-value) "Values of different types" 39 | (equal? (safe:LLVMTypeOf left-value) 40 | (safe:LLVMTypeOf right-value)) 41 | (result safe:llvm-value-ref?))) 42 | 43 | (define safe:uniop 44 | (_fun (builder : safe:LLVMBuilderRef) 45 | safe:LLVMValueRef 46 | _non-null-string -> 47 | (ptr : _pointer) -> 48 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 49 | 50 | (define safe:icmp 51 | (_fun (builder : safe:LLVMBuilderRef) 52 | LLVMIntPredicate 53 | safe:LLVMValueRef 54 | safe:LLVMValueRef 55 | _non-null-string -> 56 | (ptr : _pointer) -> 57 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 58 | 59 | (define safe:icmp/c 60 | (->i ((builder safe:llvm-builder-ref?) 61 | (predicate LLVMIntPredicate?) 62 | (left-value (builder) (safe:llvm-value-for-builder/c builder)) 63 | (right-value (builder) (safe:llvm-value-for-builder/c builder)) 64 | (name string?)) 65 | #:pre/name (left-value right-value) "Values of different types" 66 | (equal? (safe:LLVMTypeOf left-value) 67 | (safe:LLVMTypeOf right-value)) 68 | (result safe:llvm-value-ref?))) 69 | 70 | 71 | (define safe:fcmp 72 | (_fun (builder : safe:LLVMBuilderRef) 73 | LLVMRealPredicate 74 | safe:LLVMValueRef 75 | safe:LLVMValueRef 76 | _non-null-string -> 77 | (ptr : _pointer) -> 78 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 79 | 80 | (define safe:fcmp/c 81 | (->i ((builder safe:llvm-builder-ref?) 82 | (predicate LLVMRealPredicate?) 83 | (left-value (builder) (safe:llvm-value-for-builder/c builder)) 84 | (right-value (builder) (safe:llvm-value-for-builder/c builder)) 85 | (name string?)) 86 | #:pre/name (left-value right-value) "Values of different types" 87 | (equal? (safe:LLVMTypeOf left-value) 88 | (safe:LLVMTypeOf right-value)) 89 | (result safe:llvm-value-ref?))) 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | ;/* Arithmetic */ 99 | (define-llvm-multiple 100 | (LLVMBuildAdd 101 | LLVMBuildNSWAdd 102 | LLVMBuildNUWAdd 103 | LLVMBuildFAdd 104 | LLVMBuildSub 105 | LLVMBuildNSWSub 106 | LLVMBuildNUWSub 107 | LLVMBuildFSub 108 | LLVMBuildMul 109 | LLVMBuildNSWMul 110 | LLVMBuildNUWMul 111 | LLVMBuildFMul 112 | LLVMBuildUDiv 113 | LLVMBuildSDiv 114 | LLVMBuildExactSDiv 115 | LLVMBuildFDiv 116 | LLVMBuildURem 117 | LLVMBuildSRem 118 | LLVMBuildFRem 119 | LLVMBuildShl 120 | LLVMBuildLShr 121 | LLVMBuildAShr 122 | LLVMBuildAnd 123 | LLVMBuildOr 124 | LLVMBuildXor) 125 | #:unsafe (_fun LLVMBuilderRef LLVMValueRef LLVMValueRef _string -> LLVMValueRef) 126 | #:safe safe:binop 127 | (#:provide (#:safe safe:binop/c))) 128 | 129 | 130 | 131 | (define-llvm-unsafe LLVMBuildBinOp 132 | (_fun LLVMBuilderRef LLVMOpcode LLVMValueRef LLVMValueRef _string -> LLVMValueRef)) 133 | 134 | (define-llvm-multiple 135 | (LLVMBuildNeg 136 | LLVMBuildNSWNeg 137 | LLVMBuildNUWNeg 138 | LLVMBuildFNeg 139 | LLVMBuildNot) 140 | #:unsafe (_fun LLVMBuilderRef LLVMValueRef _string -> LLVMValueRef) 141 | #:safe safe:uniop) 142 | 143 | 144 | 145 | 146 | ;/* Comparisons */ 147 | (define-llvm LLVMBuildICmp 148 | #:unsafe 149 | (_fun LLVMBuilderRef 150 | LLVMIntPredicate 151 | LLVMValueRef 152 | LLVMValueRef 153 | _string -> LLVMValueRef) 154 | #:safe safe:icmp 155 | (#:provide (#:safe safe:icmp/c))) 156 | 157 | 158 | 159 | (define-llvm LLVMBuildFCmp 160 | #:unsafe 161 | (_fun LLVMBuilderRef 162 | LLVMRealPredicate 163 | LLVMValueRef 164 | LLVMValueRef 165 | _string -> LLVMValueRef) 166 | #:safe safe:fcmp 167 | (#:provide (#:safe safe:fcmp/c))) 168 | -------------------------------------------------------------------------------- /private/ffi/basic-blocks.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "define.rkt" 5 | "ctypes.rkt") 6 | 7 | (require ffi/unsafe) 8 | 9 | (provide (all-defined-out)) 10 | 11 | 12 | (define-llvm-unsafe LLVMBlockAddress (_fun LLVMValueRef LLVMBasicBlockRef -> LLVMValueRef)) 13 | 14 | 15 | 16 | ;/* Operations on basic blocks */ 17 | 18 | (define-llvm-unsafe LLVMBasicBlockAsValue (_fun LLVMBasicBlockRef -> LLVMValueRef)) 19 | (define-llvm-unsafe LLVMValueIsBasicBlock (_fun LLVMValueRef -> LLVMBool)) 20 | (define-llvm-unsafe LLVMValueAsBasicBlock (_fun LLVMValueRef -> LLVMBasicBlockRef)) 21 | (define-llvm-unsafe LLVMGetBasicBlockParent (_fun LLVMBasicBlockRef -> LLVMValueRef)) 22 | (define-llvm-unsafe LLVMGetBasicBlockTerminator (_fun LLVMBasicBlockRef -> LLVMValueRef)) 23 | 24 | 25 | (define-llvm-safe LLVMGetBasicBlockParent 26 | (_fun (bb : safe:LLVMBasicBlockRef) -> 27 | (ptr : _pointer) -> 28 | (safe:llvm-value-ref ptr (safe:llvm-basic-block-ref-module bb)))) 29 | 30 | 31 | (define-llvm-safe LLVMGetBasicBlockTerminator 32 | (_fun (bb : safe:LLVMBasicBlockRef) -> 33 | (ptr : _pointer) -> 34 | (and ptr 35 | (safe:llvm-value-ref ptr (safe:llvm-basic-block-ref-module bb))))) 36 | 37 | 38 | (define-llvm-unsafe LLVMCountBasicBlocks (_fun LLVMValueRef -> _uint)) 39 | (define-llvm-unsafe LLVMGetBasicBlocks 40 | (_fun (fun) :: 41 | (fun : LLVMValueRef) 42 | (blocks : (_list o LLVMBasicBlockRef (unsafe:LLVMCountBasicBlocks fun))) 43 | -> _void 44 | -> blocks)) 45 | 46 | (define-llvm-multiple-unsafe 47 | (LLVMGetEntryBasicBlock 48 | LLVMGetFirstBasicBlock 49 | LLVMGetLastBasicBlock) 50 | (_fun LLVMValueRef -> LLVMBasicBlockRef)) 51 | 52 | (define-llvm-multiple-unsafe 53 | (LLVMGetNextBasicBlock 54 | LLVMGetPreviousBasicBlock) 55 | (_fun LLVMBasicBlockRef -> LLVMBasicBlockRef)) 56 | 57 | (define-llvm-unsafe LLVMAppendBasicBlockInContext (_fun LLVMContextRef LLVMValueRef _string -> LLVMBasicBlockRef)) 58 | (define-llvm-unsafe LLVMInsertBasicBlockInContext (_fun LLVMContextRef LLVMBasicBlockRef _string -> LLVMBasicBlockRef)) 59 | 60 | ;TODO check that function value's context and ctx are the same 61 | ;and that it is a function value 62 | (define-llvm-safe LLVMAppendBasicBlockInContext 63 | (_fun (ctx fun name) :: 64 | (ctx : safe:LLVMContextRef) 65 | (fun : safe:LLVMValueRef) 66 | (name : _non-null-string) -> 67 | (bb : _pointer) -> 68 | (safe:llvm-basic-block-ref bb (safe:llvm-value-ref-owner fun)))) 69 | 70 | (define-llvm-unsafe LLVMAppendBasicBlock 71 | (_fun LLVMValueRef _string -> LLVMBasicBlockRef)) 72 | (define-llvm-unsafe LLVMInsertBasicBlock 73 | (_fun LLVMBasicBlockRef _string -> LLVMBasicBlockRef)) 74 | (define-llvm-unsafe LLVMDeleteBasicBlock 75 | (_fun LLVMBasicBlockRef -> _void)) 76 | ;(define-llvm-unsafe LLVMRemoveBasicBlockFromParent 77 | ; (_fun LLVMBasicBlockRef -> _void)) 78 | 79 | (define-llvm-multiple-unsafe 80 | (LLVMMoveBasicBlockBefore 81 | LLVMMoveBasicBlockAfter) 82 | (_fun LLVMBasicBlockRef LLVMBasicBlockRef -> _void)) 83 | 84 | 85 | (define-llvm-multiple-unsafe 86 | (LLVMGetFirstInstruction 87 | LLVMGetLastInstruction) 88 | (_fun LLVMBasicBlockRef -> LLVMValueRef)) 89 | 90 | -------------------------------------------------------------------------------- /private/ffi/builder.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "define.rkt" 5 | "ctypes.rkt") 6 | 7 | (require ffi/unsafe) 8 | 9 | (provide (except-out (all-defined-out) 10 | safe:position-builder-at-end)) 11 | 12 | 13 | 14 | (define safe:position-builder-at-end 15 | (_fun (builder bb) :: 16 | (builder : safe:LLVMBuilderRef) 17 | (bb : safe:LLVMBasicBlockRef) -> 18 | _void -> 19 | (begin 20 | (set-safe:llvm-builder-ref-module! builder 21 | (safe:llvm-basic-block-ref-module bb)) 22 | (void)))) 23 | 24 | ;/*===-- Instruction builders ----------------------------------------------===*/ 25 | 26 | ;/* An instruction builder represents a point within a basic block, and is the 27 | ; * exclusive means of building instructions using the C interface. 28 | ; */ 29 | 30 | (define-llvm-unsafe LLVMCreateBuilderInContext (_fun LLVMContextRef -> LLVMBuilderRef)) 31 | (define-llvm-unsafe LLVMCreateBuilder (_fun -> LLVMBuilderRef)) 32 | 33 | (define-llvm-safe LLVMCreateBuilderInContext safe:LLVMBuilderCreator) 34 | 35 | (define-llvm-unsafe LLVMPositionBuilder (_fun LLVMBuilderRef LLVMBasicBlockRef LLVMValueRef -> _void)) 36 | (define-llvm-unsafe LLVMPositionBuilderBefore 37 | (_fun LLVMBuilderRef LLVMValueRef -> _void)) 38 | 39 | (define-llvm-unsafe LLVMPositionBuilderAtEnd (_fun LLVMBuilderRef LLVMBasicBlockRef -> _void)) 40 | (define-llvm-safe LLVMPositionBuilderAtEnd safe:position-builder-at-end) 41 | 42 | (define-llvm-unsafe LLVMGetInsertBlock (_fun LLVMBuilderRef -> LLVMBasicBlockRef)) 43 | (define-llvm-safe LLVMGetInsertBlock 44 | (_fun (builder : safe:LLVMBuilderRef) -> 45 | (ptr : _pointer) -> 46 | (safe:llvm-basic-block-ref ptr (safe:llvm-builder-ref-module builder)))) 47 | 48 | (define-llvm-unsafe LLVMClearInsertionPosition 49 | (_fun LLVMBuilderRef -> _void)) 50 | 51 | (define-llvm-unsafe LLVMInsertIntoBuilder 52 | (_fun LLVMBuilderRef LLVMValueRef -> _void)) 53 | (define-llvm-unsafe LLVMInsertIntoBuilderWithName 54 | (_fun LLVMBuilderRef LLVMValueRef _string -> _void)) 55 | 56 | (define-llvm-unsafe LLVMDisposeBuilder (_fun LLVMBuilderRef -> _void)) 57 | (define (safe:LLVMDisposeBuilder builder) (void)) 58 | 59 | 60 | 61 | 62 | ;/* Metadata */ 63 | (define-llvm-unsafe LLVMGetCurrentDebugLocation (_fun LLVMBuilderRef -> LLVMValueRef)) 64 | (define-llvm-unsafe LLVMSetCurrentDebugLocation (_fun LLVMBuilderRef LLVMValueRef -> _void)) 65 | (define-llvm-unsafe LLVMSetInstDebugLocation (_fun LLVMBuilderRef LLVMValueRef -> _void)) 66 | 67 | -------------------------------------------------------------------------------- /private/ffi/cast.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "enums.rkt" 5 | "define.rkt" 6 | "ctypes.rkt") 7 | 8 | (require ffi/unsafe) 9 | 10 | 11 | ;TODO differentiate types and ensure that types match, 12 | ;and contexts match 13 | (define safe:icast 14 | (_fun (builder : safe:LLVMBuilderRef) 15 | safe:LLVMValueRef 16 | safe:LLVMTypeRef 17 | _non-null-string -> 18 | (ptr : _pointer) -> 19 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 20 | 21 | (define safe:pcast safe:icast) 22 | 23 | 24 | 25 | (provide (except-out (all-defined-out) safe:pcast safe:icast)) 26 | 27 | (define-llvm-multiple-unsafe 28 | (LLVMBuildTrunc 29 | LLVMBuildZExt 30 | LLVMBuildSExt 31 | LLVMBuildFPToUI 32 | LLVMBuildFPToSI 33 | LLVMBuildUIToFP 34 | LLVMBuildSIToFP 35 | LLVMBuildFPTrunc 36 | LLVMBuildFPExt) 37 | (_fun LLVMBuilderRef LLVMValueRef LLVMTypeRef _string -> LLVMValueRef)) 38 | 39 | (define-llvm-multiple-unsafe 40 | (LLVMBuildPtrToInt 41 | LLVMBuildIntToPtr 42 | LLVMBuildBitCast 43 | LLVMBuildZExtOrBitCast 44 | LLVMBuildSExtOrBitCast 45 | LLVMBuildTruncOrBitCast 46 | LLVMBuildPointerCast 47 | LLVMBuildIntCast 48 | LLVMBuildFPCast) 49 | (_fun LLVMBuilderRef LLVMValueRef LLVMTypeRef _string -> LLVMValueRef)) 50 | 51 | 52 | (define-llvm-multiple-safe 53 | (LLVMBuildTrunc 54 | LLVMBuildZExt 55 | LLVMBuildSExt 56 | LLVMBuildFPToUI 57 | LLVMBuildFPToSI 58 | LLVMBuildUIToFP 59 | LLVMBuildSIToFP 60 | LLVMBuildFPTrunc 61 | LLVMBuildFPExt) 62 | safe:icast) 63 | 64 | (define-llvm-multiple-safe 65 | (LLVMBuildPtrToInt 66 | LLVMBuildIntToPtr 67 | LLVMBuildBitCast 68 | LLVMBuildZExtOrBitCast 69 | LLVMBuildSExtOrBitCast 70 | LLVMBuildTruncOrBitCast 71 | LLVMBuildPointerCast 72 | LLVMBuildIntCast 73 | LLVMBuildFPCast) 74 | safe:pcast) 75 | 76 | 77 | (define-llvm-unsafe LLVMBuildCast 78 | (_fun LLVMBuilderRef LLVMOpcode LLVMValueRef LLVMTypeRef _string -> LLVMValueRef)) 79 | -------------------------------------------------------------------------------- /private/ffi/constants.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "enums.rkt" 5 | "define.rkt" 6 | "ctypes.rkt") 7 | 8 | (require ffi/unsafe) 9 | 10 | (provide (all-defined-out)) 11 | 12 | ;/* Operations on scalar constants */ 13 | (define-llvm-unsafe LLVMConstInt (_fun LLVMTypeRef _long LLVMBool -> LLVMValueRef)) 14 | (define-llvm-unsafe LLVMConstIntOfArbitraryPrecision 15 | (_fun (type words) :: 16 | (type : LLVMTypeRef) 17 | (_uint = (length words)) 18 | (words : (_list i _uint64)) 19 | -> LLVMTypeRef)) 20 | 21 | 22 | (define-llvm-safe LLVMConstInt 23 | (_fun (ty : safe:LLVMTypeRef) _long LLVMBool -> 24 | (ptr : _pointer) -> 25 | (safe:llvm-value-ref ptr (safe:llvm-type-ref-context ty)))) 26 | 27 | ;/* Operations on constants of any type */ 28 | (define-llvm-multiple-unsafe 29 | (LLVMConstNull ; /* all zeroes */ 30 | LLVMConstAllOnes ; /* only for int/vector */ 31 | LLVMGetUndef 32 | LLVMConstPointerNull) 33 | (_fun LLVMTypeRef -> LLVMValueRef)) 34 | 35 | 36 | (define-llvm-multiple-safe 37 | (LLVMConstNull ; /* all zeroes */ 38 | LLVMConstAllOnes ; /* only for int/vector */ 39 | LLVMGetUndef 40 | LLVMConstPointerNull) 41 | (_fun (ty : safe:LLVMTypeRef) -> 42 | (ptr : _pointer) -> 43 | (safe:llvm-value-ref ptr (safe:llvm-type-ref-context ty)))) 44 | 45 | 46 | 47 | (define-llvm-unsafe LLVMConstIntOfString 48 | (_fun LLVMTypeRef _string _uint8 -> LLVMValueRef)) 49 | (define-llvm-unsafe LLVMConstIntOfStringAndSize 50 | (_fun LLVMTypeRef _string _uint _uint8 -> LLVMValueRef)) 51 | 52 | (define-llvm-unsafe LLVMConstReal (_fun LLVMTypeRef _double* -> LLVMValueRef)) 53 | (define-llvm-unsafe LLVMConstRealOfString 54 | (_fun LLVMTypeRef _string -> LLVMValueRef)) 55 | (define-llvm-unsafe LLVMConstRealOfStringAndSize 56 | (_fun LLVMTypeRef _string _uint -> LLVMValueRef)) 57 | 58 | (define-llvm-safe LLVMConstReal 59 | (_fun (ty : safe:LLVMTypeRef) 60 | _double* -> 61 | (ptr : _pointer) -> 62 | (safe:llvm-value-ref ptr (safe:llvm-type-ref-context ty)))) 63 | 64 | 65 | (define-llvm-unsafe LLVMConstIntGetZExtValue (_fun LLVMValueRef -> _ulong)) 66 | (define-llvm-unsafe LLVMConstIntGetSExtValue (_fun LLVMValueRef -> _long)) 67 | 68 | ;/* Operations on composite constants */ 69 | (define-llvm-unsafe LLVMConstStringInContext 70 | (_fun (context str dnt) :: 71 | (context : LLVMContextRef) 72 | (str : _string) 73 | (_uint = (string-length str)) 74 | (dnt : LLVMBool) 75 | -> LLVMValueRef)) 76 | 77 | 78 | (define-llvm-safe LLVMConstStringInContext 79 | (_fun (context str dnt) :: 80 | (context : safe:LLVMContextRef) 81 | (str : _string) 82 | (_uint = (string-length str)) 83 | (dnt : LLVMBool) -> 84 | (ptr : _pointer) -> 85 | (safe:llvm-value-ref ptr context))) 86 | 87 | 88 | 89 | (define-llvm-unsafe LLVMConstStructInContext 90 | (_fun (context fields packed) :: 91 | (context : LLVMContextRef) 92 | (fields : (_list i LLVMValueRef)) 93 | (_uint = (length fields)) 94 | (packed : LLVMBool) 95 | -> LLVMValueRef)) 96 | 97 | 98 | (define-llvm-safe LLVMConstStructInContext 99 | (_fun (context fields packed) :: 100 | (context : safe:LLVMContextRef) 101 | (fields : (_list i safe:LLVMValueRef)) 102 | (_uint = (length fields)) 103 | (packed : LLVMBool) -> 104 | (ptr : _pointer) -> 105 | (safe:llvm-value-ref ptr context))) 106 | 107 | 108 | 109 | (define-llvm-unsafe LLVMConstString 110 | (_fun (str dnt) :: 111 | (str : _string) 112 | (_uint = (string-length str)) 113 | (dnt : LLVMBool) 114 | -> LLVMValueRef)) 115 | 116 | 117 | 118 | (define-llvm-unsafe LLVMConstStruct 119 | (_fun (fields packed) :: 120 | (fields : (_list i LLVMValueRef)) 121 | (_uint = (length fields)) 122 | (packed : LLVMBool) 123 | -> LLVMValueRef)) 124 | 125 | (define-llvm-unsafe LLVMConstNamedStruct 126 | (_fun (type fields) :: 127 | (type : LLVMTypeRef) 128 | (fields : (_list i LLVMValueRef)) 129 | (_uint = (length fields)) 130 | -> LLVMValueRef)) 131 | 132 | 133 | (define-llvm-safe LLVMConstNamedStruct 134 | (_fun (type fields) :: 135 | (type : safe:LLVMTypeRef) 136 | (fields : (_list i safe:LLVMValueRef)) 137 | (_uint = (length fields)) -> 138 | (ptr : _pointer) -> 139 | (safe:llvm-value-ref ptr (safe:llvm-type-ref-context type)))) 140 | 141 | 142 | 143 | (define-llvm-unsafe LLVMConstArray 144 | (_fun (type elements) :: 145 | (type : LLVMTypeRef) 146 | (elements : (_list i LLVMValueRef)) 147 | (_uint = (length elements)) 148 | -> LLVMValueRef)) 149 | 150 | (define-llvm-safe LLVMConstArray 151 | (_fun (type elements) :: 152 | (type : safe:LLVMTypeRef) 153 | (elements : (_list i safe:LLVMValueRef)) 154 | (_uint = (length elements)) -> 155 | (ptr : _pointer) -> 156 | (safe:llvm-value-ref ptr (safe:llvm-type-ref-context type)))) 157 | 158 | 159 | 160 | 161 | 162 | (define-llvm-unsafe LLVMConstVector 163 | (_fun (elements) :: 164 | (elements : (_list i LLVMValueRef)) 165 | (_uint = (length elements)) 166 | -> LLVMValueRef)) 167 | 168 | (define-llvm-safe LLVMConstVector 169 | (_fun (elems) :: 170 | (elements : (_list i safe:LLVMValueRef) = elems) 171 | (_uint = (length elements)) 172 | -> (ptr : _pointer) 173 | -> (safe:llvm-value-ref ptr (safe:llvm-value-ref-owner (first elems))))) 174 | 175 | 176 | 177 | (define-llvm-unsafe LLVMGetConstOpcode (_fun LLVMValueRef -> LLVMOpcode)) 178 | (define-llvm-multiple-unsafe 179 | (LLVMAlignOf LLVMSizeOf) (_fun LLVMTypeRef -> LLVMValueRef)) 180 | 181 | (define-llvm-multiple-unsafe 182 | (LLVMConstNeg 183 | LLVMConstNSWNeg 184 | LLVMConstNUWNeg 185 | LLVMConstFNeg 186 | LLVMConstNot) 187 | (_fun LLVMValueRef -> LLVMValueRef)) 188 | 189 | (define-llvm-multiple-unsafe 190 | (LLVMConstAdd 191 | LLVMConstNSWAdd 192 | LLVMConstNUWAdd 193 | LLVMConstFAdd 194 | LLVMConstSub 195 | LLVMConstNSWSub 196 | LLVMConstNUWSub 197 | LLVMConstFSub 198 | LLVMConstMul 199 | LLVMConstNSWMul 200 | LLVMConstNUWMul 201 | LLVMConstFMul 202 | LLVMConstUDiv 203 | LLVMConstSDiv 204 | LLVMConstExactSDiv 205 | LLVMConstFDiv 206 | LLVMConstURem 207 | LLVMConstSRem 208 | LLVMConstFRem 209 | LLVMConstAnd 210 | LLVMConstOr 211 | LLVMConstXor) 212 | (_fun LLVMValueRef LLVMValueRef -> LLVMValueRef)) 213 | 214 | 215 | (define-llvm-unsafe LLVMConstICmp 216 | (_fun LLVMIntPredicate LLVMValueRef LLVMValueRef -> LLVMValueRef)) 217 | (define-llvm-unsafe LLVMConstFCmp 218 | (_fun LLVMRealPredicate LLVMValueRef LLVMValueRef -> LLVMValueRef)) 219 | (define-llvm-multiple-unsafe 220 | (LLVMConstShl LLVMConstLShr LLVMConstAShr) 221 | (_fun LLVMValueRef LLVMValueRef -> LLVMValueRef)) 222 | (define-llvm-multiple-unsafe (LLVMConstGEP LLVMConstInBoundsGEP) 223 | (_fun (ptr indices) :: 224 | (ptr : LLVMValueRef) 225 | (indices : (_list i LLVMValueRef)) 226 | (_uint = (length indices)) 227 | -> LLVMValueRef)) 228 | 229 | 230 | (define-llvm-multiple-unsafe 231 | (LLVMConstTrunc 232 | LLVMConstSExt 233 | LLVMConstZExt 234 | LLVMConstFPTrunc 235 | LLVMConstFPExt 236 | LLVMConstUIToFP 237 | LLVMConstSIToFP 238 | LLVMConstFPToUI 239 | LLVMConstFPToSI 240 | LLVMConstPtrToInt 241 | LLVMConstIntToPtr 242 | LLVMConstBitCast 243 | LLVMConstZExtOrBitCast 244 | LLVMConstSExtOrBitCast 245 | LLVMConstTruncOrBitCast 246 | LLVMConstPointerCast) 247 | (_fun LLVMValueRef LLVMTypeRef -> LLVMValueRef)) 248 | 249 | 250 | (define-llvm-unsafe LLVMConstIntCast 251 | (_fun LLVMValueRef LLVMTypeRef LLVMBool -> LLVMValueRef)) 252 | 253 | (define-llvm-unsafe LLVMConstFPCast 254 | (_fun LLVMValueRef LLVMTypeRef -> LLVMValueRef)) 255 | 256 | (define-llvm-multiple-unsafe 257 | (LLVMConstSelect 258 | LLVMConstInsertElement 259 | LLVMConstShuffleVector) 260 | (_fun LLVMValueRef LLVMValueRef LLVMValueRef -> LLVMValueRef)) 261 | 262 | (define-llvm-unsafe LLVMConstExtractElement 263 | (_fun LLVMValueRef LLVMValueRef -> LLVMValueRef)) 264 | 265 | (define-llvm-unsafe LLVMConstExtractValue 266 | (_fun (agg indices) :: 267 | (agg : LLVMValueRef) 268 | (indices : (_list i _uint)) 269 | (_uint = (length indices)) 270 | -> 271 | LLVMValueRef)) 272 | 273 | 274 | (define-llvm-unsafe LLVMConstInsertValue 275 | (_fun (agg elem indices) :: 276 | (agg : LLVMValueRef) 277 | (elem : LLVMValueRef) 278 | (indices : (_list i _uint)) 279 | (_uint = (length indices)) 280 | -> 281 | LLVMValueRef)) 282 | 283 | (define-llvm-unsafe LLVMConstInlineAsm (_fun LLVMTypeRef _string _string LLVMBool LLVMBool -> LLVMValueRef)) 284 | -------------------------------------------------------------------------------- /private/ffi/define.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require typed/racket 4 | syntax/parse/define 5 | racket/stxparam 6 | racket/splicing 7 | 8 | (for-syntax "../llvm-util-exptime.rkt" syntax/parse) 9 | (only-in ffi/unsafe get-ffi-obj) 10 | "lib.rkt") 11 | 12 | 13 | (provide 14 | define-llvm 15 | define-llvm-multiple 16 | define-llvm-safe 17 | define-llvm-racket-safe 18 | define-llvm-multiple-safe 19 | define-llvm-unsafe 20 | define-llvm-racket-unsafe 21 | define-llvm-multiple-unsafe 22 | define-llvm-safety-parameter 23 | with-llvm-safety) 24 | 25 | 26 | 27 | (define-syntax (define-ffi-definer stx) 28 | (syntax-case stx () 29 | ((_ name lib) 30 | #'(define-syntax (name stx) 31 | (syntax-case stx () 32 | ((_ id type #:c-id c-id) 33 | #'(define id (get-ffi-obj 'c-id lib type))) 34 | ((_ id type) 35 | #'(define id (get-ffi-obj 'id lib type)))))))) 36 | 37 | 38 | 39 | (define-syntax-parameter llvm-safety #f) 40 | 41 | (define-syntax define-llvm-safety-parameter 42 | (syntax-parser 43 | ((_ name:id body:expr) 44 | #'(define-llvm-safety-parameter #:safe body #:unsafe body)) 45 | ((_ name:id (~seq (~or (~once (~seq #:safe safe-expr:expr)) 46 | (~once (~seq #:unsafe unsafe-expr:expr))) ...)) 47 | #'(begin 48 | (define safe-id (with-llvm-safety #:safe safe-expr)) 49 | (define unsafe-id (with-llvm-safety #:unsafe unsafe-expr)) 50 | (define-syntax (name stx) 51 | (let () 52 | (define (get-id) 53 | (let ((val (syntax-parameter-value #'llvm-safety))) 54 | (case val 55 | ((#f) (raise-syntax-error 'llvm-safety "llvm-safety has not been set in this scope" stx)) 56 | ((unsafe) #'unsafe-id) 57 | ((safe) #'safe-id) 58 | (else (error 'llvm-safety "Bad value for llvm-safety: ~s" val))))) 59 | (... 60 | (syntax-parse stx 61 | ((_ a ...) #'(#,(get-id) a ...)) 62 | (_ (get-id)))))))))) 63 | (define-syntax with-llvm-safety 64 | (syntax-parser 65 | ((_ #:both body:expr ...) 66 | #'(values (with-llvm-safety #:safe body ...) (with-llvm-safety #:unsafe body ...))) 67 | ((_ (~or (~and #:safe (~bind (safety #''safe))) 68 | (~and #:unsafe (~bind (safety #''unsafe)))) 69 | body:expr ...) 70 | #'(syntax-parameterize ((llvm-safety safety)) 71 | body ...)))) 72 | 73 | 74 | (define-ffi-definer define-llvm-raw llvm-lib) 75 | (define-ffi-definer define-llvm-racket-raw llvm-racket-lib) 76 | 77 | 78 | (define-syntaxes 79 | (define-llvm-unsafe 80 | define-llvm-racket-unsafe 81 | define-llvm-safe 82 | define-llvm-racket-safe) 83 | (let ((definer 84 | (lambda (define-llvm safety) 85 | (define safety-symbol (if safety 'safe 'unsafe)) 86 | (syntax-parser 87 | ((_ name:id type:expr) 88 | (with-syntax ((id (id-prefix safety-symbol (id-prefix ': #'name)))) 89 | #`(splicing-syntax-parameterize ((llvm-safety '#,safety-symbol)) 90 | (#,define-llvm id type #:c-id name)))))))) 91 | (values 92 | (definer #'define-llvm-raw #f) 93 | (definer #'define-llvm-racket-raw #f) 94 | (definer #'define-llvm-raw #t) 95 | (definer #'define-llvm-racket-raw #t)))) 96 | 97 | 98 | 99 | (begin-for-syntax 100 | 101 | (define (add-safe-prefix id) (id-prefix 'safe: id)) 102 | (define (add-unsafe-prefix id) (id-prefix 'unsafe: id)) 103 | (define (null-provide id) #'(begin)) 104 | (define (simple-provide id) #`(provide #,id)) 105 | (define ((contracted-provide contract) id) 106 | #`(provide (contract-out (#,id #,contract)))) 107 | 108 | 109 | (define-splicing-syntax-class (inner-provide-clause keyword) 110 | #:attributes (provide) 111 | (pattern (~seq) #:attr provide simple-provide) 112 | (pattern (~seq key) 113 | #:when (equal? (syntax-e (attribute key)) keyword) 114 | #:attr provide simple-provide) 115 | (pattern (~seq (key #:no)) 116 | #:when (equal? (syntax-e (attribute key)) keyword) 117 | #:attr provide null-provide) 118 | (pattern (~seq (key contract:expr)) 119 | #:when (equal? (syntax-e (attribute key)) keyword) 120 | #:attr provide (contracted-provide #'contract))) 121 | 122 | (define-syntax-class provide-clause 123 | #:attributes (safe unsafe) 124 | (pattern 125 | (#:provide 126 | (~seq (~or (~once (~var safe-inner (inner-provide-clause '#:safe))) 127 | (~once (~var unsafe-inner (inner-provide-clause '#:unsafe)))) ...)) 128 | #:attr safe (attribute safe-inner.provide) 129 | #:attr unsafe (attribute unsafe-inner.provide))) 130 | 131 | (define-splicing-syntax-class ctype-clause 132 | #:attributes (safe unsafe) 133 | (pattern (~seq #:both type:expr) #:attr safe #'type #:attr unsafe #'type) 134 | (pattern (~seq (~or (~once (~seq #:safe safe:expr)) (~once (~seq #:unsafe unsafe:expr))) ...)))) 135 | 136 | 137 | 138 | (define-syntax define-llvm 139 | (syntax-parser 140 | ((_ name:id 141 | types:ctype-clause 142 | (~optional provide:provide-clause 143 | #:defaults ((provide.safe simple-provide) (provide.unsafe simple-provide)))) 144 | (define safe-name (add-safe-prefix #'name)) 145 | (define unsafe-name (add-unsafe-prefix #'name)) 146 | #`(begin 147 | (define-llvm-safe name types.safe) 148 | (define-llvm-unsafe name types.unsafe) 149 | #,((attribute provide.safe) safe-name) 150 | #,((attribute provide.unsafe) unsafe-name))))) 151 | 152 | (define-syntax define-llvm-multiple 153 | (syntax-parser 154 | ((_ (name:id ...) . rest) 155 | #'(begin 156 | (define-llvm name . rest) ...)))) 157 | 158 | 159 | 160 | 161 | (define-syntax (define-llvm-multiple-unsafe stx) 162 | (syntax-parse stx 163 | ((_ (name:id ...) type:expr) 164 | #'(begin (define-llvm-unsafe name type) ...)))) 165 | 166 | (define-syntax (define-llvm-multiple-safe stx) 167 | (syntax-parse stx 168 | ((_ (name:id ...) type:expr) 169 | #'(begin (define-llvm-safe name type) ...)))) 170 | 171 | 172 | 173 | -------------------------------------------------------------------------------- /private/ffi/enums.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | (for-syntax 5 | racket/base 6 | racket/list 7 | racket/string 8 | racket/syntax 9 | racket/match 10 | racket/string 11 | syntax/parse 12 | "../llvm-headers.rkt") 13 | racket/contract 14 | (only-in ffi/unsafe _enum)) 15 | 16 | (define-for-syntax (generate-enum-code2 nm enum-values) 17 | (define/with-syntax name nm) 18 | (define/with-syntax name? (format-id nm "~a?" nm)) 19 | 20 | (define enum-list 21 | (append* 22 | (for/list ([(name value) (in-hash enum-values)]) 23 | `(,name = ,value)))) 24 | (define quoted-enum-symbols 25 | (for/list ((symbol (hash-keys enum-values))) 26 | #`'#,symbol)) 27 | #`(begin 28 | (provide name name?) 29 | (define name (_enum '#,enum-list)) 30 | (define name? (or/c #,@quoted-enum-symbols)))) 31 | 32 | (begin-for-syntax 33 | (define (namespace-get-namespaces ns names) 34 | (for/fold ([ns ns]) ([name names]) 35 | (namespace-get-namespace ns name))) 36 | (define-syntax-class namespaced-id 37 | #:attributes (name namespaces) 38 | (pattern name:id 39 | #:attr namespaces '()) 40 | (pattern (nss:id ... name:id) 41 | #:attr namespaces (syntax->datum #'(nss ...)))) 42 | (define-splicing-syntax-class declaration 43 | #:attributes (generator) 44 | (pattern (~seq :namespaced-id 45 | (~optional (~seq #:name alt-name)) 46 | (~optional (~seq #:rename rename) #:defaults ([rename #'values]))) 47 | #:with external-name (or (attribute alt-name) #'name) 48 | #:with external-predicate (format-id #'external-name "~a?" #'external-name) 49 | #:attr generator 50 | (λ (ns) 51 | (generate-enum-code2 52 | #'external-name 53 | (namespace-get-typedef (namespace-get-namespaces ns (attribute namespaces)) 54 | (syntax-e #'name))))) 55 | (pattern (~seq #:enum :namespaced-id 56 | (~optional (~seq #:name alt-name)) 57 | (~optional (~seq #:rename rename) #:defaults ([rename #'values])) 58 | ) 59 | #:with external-name (or (attribute alt-name) #'name) 60 | #:with external-predicate (format-id #'external-name "~a?" #'external-name) 61 | #:attr generator 62 | (λ (ns) 63 | (generate-enum-code2 64 | #'external-name 65 | (namespace-get-enum (namespace-get-namespaces ns (attribute namespaces)) 66 | (syntax-e #'name))))))) 67 | 68 | (define-syntax define-enums 69 | (syntax-parser 70 | [(_ header-file:str #:lang lang:id decl:declaration ...) 71 | (define ns (read-header (syntax-e #'header-file) #:lang (syntax-e #'lang))) 72 | #`(begin 73 | #,@(for/list ([gen (in-list (attribute decl.generator))]) 74 | (gen ns)))])) 75 | (define-for-syntax (underscore->hypen symbol) 76 | (string->symbol (string-replace (symbol->string symbol) "_" "-"))) 77 | 78 | (define-enums "llvm-c/Core.h" #:lang c 79 | LLVMAttribute 80 | LLVMOpcode 81 | LLVMTypeKind 82 | LLVMLinkage 83 | LLVMVisibility 84 | LLVMCallConv 85 | LLVMIntPredicate 86 | LLVMRealPredicate 87 | LLVMLandingPadClauseTy) 88 | 89 | (define-enums "llvm/IR/Intrinsics.h" #:lang c++ 90 | #:enum (llvm Intrinsic ID) #:name LLVMIntrinsic #:rename underscore->hyphen) 91 | 92 | -------------------------------------------------------------------------------- /private/ffi/functions.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "enums.rkt" 5 | "define.rkt" 6 | "ctypes.rkt") 7 | 8 | (require ffi/unsafe) 9 | 10 | (provide (all-defined-out)) 11 | 12 | 13 | ;/* Operations on functions */ 14 | (define-llvm-unsafe LLVMAddFunction (_fun LLVMModuleRef _string LLVMTypeRef -> LLVMValueRef)) 15 | 16 | (define-llvm-safe LLVMAddFunction 17 | (_fun (mod : safe:LLVMModuleRef) 18 | _non-null-string 19 | safe:LLVMTypeRef -> 20 | (ptr : _pointer) -> 21 | (safe:llvm-value-ref ptr mod))) 22 | 23 | (define-llvm-unsafe LLVMGetNamedFunction (_fun LLVMModuleRef _string -> LLVMValueRef)) 24 | 25 | (define-llvm-safe LLVMGetNamedFunction 26 | (_fun (mod : safe:LLVMModuleRef) 27 | _non-null-string -> 28 | (ptr : _pointer) -> 29 | (and ptr 30 | (safe:llvm-value-ref ptr mod)))) 31 | 32 | 33 | (define-llvm-multiple-unsafe 34 | (LLVMGetFirstFunction 35 | LLVMGetLastFunction) 36 | (_fun LLVMModuleRef -> LLVMValueRef)) 37 | 38 | (define-llvm-multiple-unsafe 39 | (LLVMGetNextFunction 40 | LLVMGetPreviousFunction) 41 | (_fun LLVMValueRef -> LLVMValueRef)) 42 | 43 | (define-llvm-unsafe LLVMDeleteFunction 44 | (_fun LLVMValueRef -> _void)) 45 | 46 | (define-llvm-unsafe LLVMGetIntrinsicID 47 | (_fun LLVMValueRef -> _uint)) 48 | 49 | (define-llvm-unsafe LLVMGetFunctionCallConv 50 | (_fun LLVMValueRef -> LLVMCallConv)) 51 | 52 | (define-llvm-unsafe LLVMSetFunctionCallConv 53 | (_fun LLVMValueRef LLVMCallConv -> _void)) 54 | 55 | (define-llvm-safe LLVMSetFunctionCallConv 56 | (_fun safe:LLVMValueRef LLVMCallConv -> _void)) 57 | 58 | 59 | (define-llvm-unsafe LLVMGetGC 60 | (_fun LLVMValueRef -> _string)) 61 | (define-llvm-unsafe LLVMSetGC (_fun LLVMValueRef _string -> _void)) 62 | 63 | 64 | (define-llvm-multiple-unsafe 65 | (LLVMAddFunctionAttr 66 | LLVMRemoveFunctionAttr) 67 | (_fun LLVMValueRef LLVMAttribute -> _void)) 68 | 69 | (define-llvm-multiple-safe 70 | (LLVMAddFunctionAttr 71 | LLVMRemoveFunctionAttr) 72 | (_fun safe:LLVMValueRef LLVMAttribute -> _void)) 73 | 74 | 75 | (define-llvm-unsafe LLVMGetFunctionAttr 76 | (_fun LLVMValueRef -> LLVMAttribute)) 77 | 78 | 79 | ;/* Operations on parameters */ 80 | 81 | (define-llvm-unsafe LLVMCountParams (_fun LLVMValueRef -> _uint)) 82 | (define-llvm-unsafe LLVMGetParams 83 | (_fun (fun) :: 84 | (fun : LLVMValueRef) 85 | (params : (_list o LLVMValueRef (unsafe:LLVMCountParams fun))) 86 | -> _void 87 | -> params)) 88 | 89 | (define-llvm-unsafe LLVMGetParam (_fun LLVMValueRef _uint -> LLVMValueRef)) 90 | (define-llvm-safe LLVMGetParam 91 | (_fun (f : safe:LLVMValueRef) 92 | _uint -> 93 | (ptr : _pointer) -> 94 | (safe:llvm-value-ref ptr (safe:llvm-value-ref-owner f)))) 95 | 96 | (define-llvm-unsafe LLVMGetParamParent (_fun LLVMValueRef -> LLVMValueRef)) 97 | 98 | (define-llvm-multiple-unsafe 99 | (LLVMGetFirstParam 100 | LLVMGetLastParam) 101 | (_fun LLVMValueRef -> LLVMValueRef)) 102 | 103 | (define-llvm-multiple-unsafe 104 | (LLVMGetNextParam 105 | LLVMGetPreviousParam) 106 | (_fun LLVMValueRef -> LLVMValueRef)) 107 | 108 | (define-llvm-multiple-unsafe 109 | (LLVMAddAttribute 110 | LLVMRemoveAttribute) 111 | (_fun LLVMValueRef LLVMAttribute -> _void)) 112 | 113 | (define-llvm-unsafe LLVMGetAttribute (_fun LLVMValueRef -> LLVMAttribute)) 114 | (define-llvm-unsafe LLVMSetParamAlignment (_fun LLVMValueRef _uint -> _void)) 115 | 116 | 117 | -------------------------------------------------------------------------------- /private/ffi/globals.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "enums.rkt" 5 | "define.rkt" 6 | "ctypes.rkt") 7 | 8 | (require ffi/unsafe) 9 | 10 | (provide (all-defined-out)) 11 | 12 | ;/* Operations on global variables, functions, and aliases (globals) */ 13 | (define-llvm-unsafe LLVMGetGlobalParent (_fun LLVMValueRef -> LLVMModuleRef)) 14 | 15 | (define-llvm-safe LLVMGetGlobalParent 16 | (_fun (v : safe:LLVMValueRef) -> 17 | (ptr : _pointer) -> 18 | (let ((o (safe:llvm-value-ref-owner v))) 19 | (if (equal? ptr (safe:llvm-module-ref-pointer o)) 20 | o 21 | (error 'safe:llvm-value-ref "Parent is incorrect ~a: should be ~a" v ptr))))) 22 | 23 | 24 | (define-llvm-unsafe LLVMIsDeclaration (_fun LLVMValueRef -> LLVMBool)) 25 | 26 | (define-llvm-unsafe LLVMGetLinkage (_fun LLVMValueRef -> LLVMLinkage)) 27 | (define-llvm-unsafe LLVMSetLinkage (_fun LLVMValueRef LLVMLinkage -> _void)) 28 | 29 | (define-llvm-safe LLVMGetLinkage (_fun safe:LLVMValueRef -> LLVMLinkage)) 30 | (define-llvm-safe LLVMSetLinkage (_fun safe:LLVMValueRef LLVMLinkage -> _void)) 31 | 32 | 33 | (define-llvm-unsafe LLVMGetSection (_fun LLVMValueRef -> _string)) 34 | (define-llvm-unsafe LLVMSetSection (_fun LLVMValueRef _string -> _void)) 35 | 36 | (define-llvm-safe LLVMGetSection (_fun safe:LLVMValueRef -> _string)) 37 | (define-llvm-safe LLVMSetSection (_fun safe:LLVMValueRef _string -> _void)) 38 | 39 | (define-llvm-unsafe LLVMGetVisibility (_fun LLVMValueRef -> LLVMVisibility)) 40 | (define-llvm-unsafe LLVMSetVisibility (_fun LLVMValueRef LLVMVisibility -> _void)) 41 | 42 | (define-llvm-safe LLVMGetVisibility (_fun safe:LLVMValueRef -> LLVMVisibility)) 43 | (define-llvm-safe LLVMSetVisibility (_fun safe:LLVMValueRef LLVMVisibility -> _void)) 44 | 45 | (define-llvm-unsafe LLVMGetAlignment (_fun LLVMValueRef -> _uint)) 46 | (define-llvm-unsafe LLVMSetAlignment (_fun LLVMValueRef _uint -> _void)) 47 | 48 | (define-llvm-safe LLVMGetAlignment (_fun safe:LLVMValueRef -> _uint)) 49 | (define-llvm-safe LLVMSetAlignment (_fun safe:LLVMValueRef _uint -> _void)) 50 | 51 | 52 | ;/* Operations on global variables */ 53 | (define-llvm-unsafe LLVMAddGlobal 54 | (_fun LLVMModuleRef LLVMTypeRef _string -> LLVMValueRef)) 55 | 56 | (define-llvm-safe LLVMAddGlobal 57 | (_fun (mod : safe:LLVMModuleRef) 58 | safe:LLVMTypeRef 59 | _non-null-string -> 60 | (ptr : _pointer) -> 61 | (safe:llvm-value-ref ptr mod))) 62 | 63 | 64 | 65 | 66 | (define-llvm-unsafe LLVMAddGlobalInAddressSpace 67 | (_fun LLVMModuleRef LLVMTypeRef _string _uint -> LLVMValueRef)) 68 | 69 | (define-llvm-unsafe LLVMGetNamedGlobal (_fun LLVMModuleRef _string -> LLVMValueRef)) 70 | 71 | (define-llvm-safe LLVMGetNamedGlobal 72 | (_fun (mod : safe:LLVMModuleRef) 73 | _non-null-string -> 74 | (ptr : _pointer) -> 75 | (and ptr 76 | (safe:llvm-value-ref ptr mod)))) 77 | 78 | (define-llvm-multiple-unsafe 79 | (LLVMGetFirstGlobal LLVMGetLastGlobal) 80 | (_fun LLVMModuleRef -> LLVMValueRef)) 81 | 82 | (define-llvm-multiple-unsafe 83 | (LLVMGetNextGlobal 84 | LLVMGetPreviousGlobal 85 | LLVMDeleteGlobal 86 | LLVMGetInitializer) 87 | (_fun LLVMValueRef -> LLVMValueRef)) 88 | 89 | 90 | (define-llvm-multiple-safe 91 | (LLVMGetNextGlobal 92 | LLVMGetPreviousGlobal 93 | LLVMGetInitializer) 94 | (_fun safe:LLVMValueRef -> safe:LLVMValueRef)) 95 | 96 | 97 | (define-llvm-unsafe LLVMSetInitializer (_fun LLVMValueRef LLVMValueRef -> _void)) 98 | (define-llvm-safe LLVMSetInitializer (_fun safe:LLVMValueRef safe:LLVMValueRef -> _void)) 99 | 100 | (define-llvm-multiple-unsafe 101 | (LLVMIsThreadLocal LLVMIsGlobalConstant) 102 | (_fun LLVMValueRef -> LLVMBool)) 103 | (define-llvm-multiple-unsafe 104 | (LLVMSetThreadLocal LLVMSetGlobalConstant) 105 | (_fun LLVMValueRef LLVMBool -> _void)) 106 | 107 | 108 | (define-llvm-multiple-safe 109 | (LLVMIsThreadLocal LLVMIsGlobalConstant) 110 | (_fun safe:LLVMValueRef -> LLVMBool)) 111 | (define-llvm-multiple-safe 112 | (LLVMSetThreadLocal LLVMSetGlobalConstant) 113 | (_fun safe:LLVMValueRef LLVMBool -> _void)) 114 | 115 | 116 | 117 | ;/* Operations on aliases */ 118 | 119 | (define-llvm-unsafe LLVMAddAlias 120 | (_fun LLVMModuleRef LLVMTypeRef LLVMValueRef _string -> LLVMValueRef)) 121 | -------------------------------------------------------------------------------- /private/ffi/instructions.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "enums.rkt" 5 | "define.rkt" 6 | "ctypes.rkt") 7 | 8 | (require ffi/unsafe) 9 | 10 | (provide (all-defined-out)) 11 | 12 | ;/* Operations on instructions */ 13 | (define-llvm-unsafe LLVMGetInstructionParent (_fun LLVMValueRef -> LLVMBasicBlockRef)) 14 | (define-llvm-multiple-unsafe 15 | (LLVMGetNextInstruction 16 | LLVMGetPreviousInstruction) 17 | (_fun LLVMValueRef -> LLVMValueRef)) 18 | 19 | 20 | (define-llvm-safe LLVMGetInstructionParent 21 | (_fun (v : safe:LLVMValueRef) -> 22 | (ptr : _pointer) -> 23 | (safe:llvm-basic-block-ref ptr (safe:llvm-value-ref-owner v)))) 24 | 25 | 26 | ;/* Operations on call sites */ 27 | 28 | (define-llvm-unsafe LLVMGetInstructionCallConv (_fun LLVMValueRef -> LLVMCallConv)) 29 | (define-llvm-unsafe LLVMSetInstructionCallConv (_fun LLVMValueRef LLVMCallConv -> _void)) 30 | 31 | (define-llvm-safe LLVMGetInstructionCallConv (_fun safe:LLVMValueRef -> LLVMCallConv)) 32 | (define-llvm-safe LLVMSetInstructionCallConv (_fun safe:LLVMValueRef LLVMCallConv -> _void)) 33 | 34 | 35 | (define-llvm-unsafe LLVMAddInstrAttribute (_fun LLVMValueRef _uint LLVMAttribute -> _void)) 36 | (define-llvm-unsafe LLVMRemoveInstrAttribute (_fun LLVMValueRef _uint LLVMAttribute -> _void)) 37 | 38 | (define-llvm-unsafe LLVMSetInstrParamAlignment (_fun LLVMValueRef _uint _uint -> _void)) 39 | 40 | 41 | ;/* Operations on call instructions (only) */ 42 | 43 | (define-llvm-unsafe LLVMIsTailCall (_fun LLVMValueRef -> LLVMBool)) 44 | (define-llvm-unsafe LLVMSetTailCall (_fun LLVMValueRef LLVMBool -> _void)) 45 | 46 | (define-llvm-safe LLVMIsTailCall (_fun safe:LLVMValueRef -> LLVMBool)) 47 | (define-llvm-safe LLVMSetTailCall (_fun safe:LLVMValueRef LLVMBool -> _void)) 48 | 49 | 50 | ;/* Operations on switch instructions (only) */ 51 | ;(define-llvm-unsafe LLVMGetSwitchDefaultDest (_fun LLVMValueRef -> LLVMBasicBlockRef)) 52 | 53 | ;/* Operations on phi nodes */ 54 | (define-llvm-unsafe LLVMAddIncoming 55 | (_fun (phi values blocks) :: 56 | (phi : LLVMValueRef) 57 | (values : (_list i LLVMValueRef)) 58 | (blocks : (_list i LLVMBasicBlockRef)) 59 | (list : _uint = (min (length values) (length blocks))) 60 | -> _void)) 61 | 62 | 63 | ;/* Operations on phi nodes */ 64 | (define-llvm-safe LLVMAddIncoming 65 | (_fun (phi values blocks) :: 66 | (phi : safe:LLVMValueRef) 67 | (values : (_list i safe:LLVMValueRef)) 68 | (blocks : (_list i safe:LLVMBasicBlockRef)) 69 | (list : _uint = (min (length values) (length blocks))) 70 | -> _void)) 71 | 72 | 73 | 74 | (define-llvm-unsafe LLVMCountIncoming (_fun LLVMValueRef -> _uint)) 75 | (define-llvm-unsafe LLVMGetIncomingValue (_fun LLVMValueRef _uint -> LLVMValueRef)) 76 | (define-llvm-unsafe LLVMGetIncomingBlock (_fun LLVMValueRef _uint -> LLVMBasicBlockRef)) 77 | 78 | -------------------------------------------------------------------------------- /private/ffi/intrinsics.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require ffi/unsafe "define.rkt" "enums.rkt" "ctypes.rkt") 4 | 5 | (provide safe:LLVMGetIntrinsic) 6 | 7 | 8 | (define-llvm-racket-unsafe LLVMGetIntrinsic 9 | (_fun (mod id types) :: 10 | (mod : LLVMModuleRef) 11 | (id : LLVMIntrinsic) 12 | (types : (_list i LLVMTypeRef)) 13 | (_uint = (length types)) -> 14 | LLVMValueRef)) 15 | 16 | (define-llvm-racket-safe LLVMGetIntrinsic 17 | (_fun (mod id types) :: 18 | (mod : safe:LLVMModuleRef) 19 | (id : LLVMIntrinsic) 20 | (types : (_list i safe:LLVMTypeRef)) 21 | (_uint = (length types)) -> 22 | (ptr : _pointer) -> 23 | (safe:llvm-value-ref ptr mod))) 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | -------------------------------------------------------------------------------- /private/ffi/lib.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | (require 4 | racket/port) 5 | 6 | 7 | (require/typed ffi/unsafe 8 | (#:opaque FFI-Lib ffi-lib?) 9 | (#:opaque CType ctype?) 10 | ;very specific type for this use case 11 | (get-ffi-obj (Symbol FFI-Lib CType -> (-> Any))) 12 | (_cprocedure ((Listof CType) CType -> CType)) 13 | (_void CType) 14 | (ffi-lib (Path [#:global? Boolean] -> FFI-Lib))) 15 | 16 | (require (only-in ffi/unsafe _fun (-> ffi:->))) 17 | 18 | (require/typed "paths.rkt" 19 | (llvm-racket-lib-path Path)) 20 | (require/typed srfi/13 21 | (string-trim-both (String -> String))) 22 | 23 | 24 | (provide 25 | llvm-lib 26 | llvm-racket-lib) 27 | 28 | (define llvm-version-string 29 | (let-values (((process out in err) (subprocess #f #f #f "/usr/bin/env" "llvm-config" "--version"))) 30 | (begin0 31 | (string-trim-both (port->string out)) 32 | (close-output-port in) 33 | (close-input-port err) 34 | (close-input-port out) 35 | (subprocess-wait process) 36 | (unless (equal? (subprocess-status process) 0) (error 'llvm-config "Returned non zero exit code"))))) 37 | 38 | (define llvm-lib-path 39 | (let-values (((process out in err) (subprocess #f #f #f "/usr/bin/env" "llvm-config" "--libdir"))) 40 | (begin0 41 | (string-trim-both (port->string out)) 42 | (close-output-port in) 43 | (close-input-port err) 44 | (close-input-port out) 45 | (subprocess-wait process) 46 | (unless (equal? (subprocess-status process) 0) (error 'llvm-config "Returned non zero exit code"))))) 47 | 48 | 49 | 50 | (define llvm-lib 51 | (let ((lib-name (string-append "libLLVM-" llvm-version-string))) 52 | (ffi-lib 53 | (case (system-type 'os) 54 | ((macosx) (build-path llvm-lib-path lib-name)) 55 | ((unix) (string->path lib-name)) 56 | ((windows) (string->path lib-name))) 57 | #:global? #t))) 58 | 59 | (define llvm-racket-lib (ffi-lib (path-replace-suffix llvm-racket-lib-path ""))) 60 | 61 | (define cthunk 62 | (_cprocedure null _void)) 63 | 64 | ((get-ffi-obj 'LLVMInitializeRacket llvm-racket-lib cthunk)) 65 | ;((get-ffi-obj 'LLVMInitializeX86TargetInfo llvm-lib cthunk)) 66 | ;((get-ffi-obj 'LLVMInitializeX86Target llvm-lib cthunk)) 67 | 68 | 69 | 70 | 71 | -------------------------------------------------------------------------------- /private/ffi/memory-buffers.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "define.rkt" 5 | "ctypes.rkt") 6 | 7 | (require ffi/unsafe) 8 | 9 | (provide (all-defined-out)) 10 | 11 | ;/*===-- Memory buffers ----------------------------------------------------===*/ 12 | ; 13 | (define-llvm-unsafe LLVMCreateMemoryBufferWithContentsOfFile 14 | (_fun (path) :: 15 | (path : _string) 16 | (buffer : (_ptr o LLVMMemoryBufferRef)) 17 | (message : (_ptr io LLVMMessage) = #f) 18 | -> 19 | (ans : LLVMBool) 20 | -> 21 | (if ans message buffer))) 22 | 23 | (define-llvm-safe LLVMCreateMemoryBufferWithContentsOfFile 24 | safe:LLVMMemoryBufferCreatorFromFile) 25 | 26 | (define-llvm-unsafe LLVMCreateMemoryBufferWithSTDIN 27 | (_fun () :: 28 | (buffer : (_ptr o LLVMMemoryBufferRef)) 29 | (message : (_ptr io LLVMMessage) = #f) 30 | -> 31 | (ans : LLVMBool) 32 | -> 33 | (if ans message buffer))) 34 | 35 | (define-llvm-unsafe LLVMDisposeMemoryBuffer 36 | (_fun LLVMMemoryBufferRef -> _void)) 37 | 38 | 39 | 40 | -------------------------------------------------------------------------------- /private/ffi/memory.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "define.rkt" 5 | "ctypes.rkt") 6 | 7 | (require ffi/unsafe) 8 | 9 | (provide (except-out (all-defined-out) 10 | safe:alloc safe:array-alloc safe:free 11 | safe:load safe:store 12 | safe:gep safe:struct-gep safe:string-builder)) 13 | 14 | 15 | (define safe:alloc 16 | (_fun (builder : safe:LLVMBuilderRef) 17 | safe:LLVMTypeRef 18 | _non-null-string -> 19 | (ptr : _pointer) -> 20 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 21 | 22 | (define safe:array-alloc 23 | (_fun (builder : safe:LLVMBuilderRef) 24 | safe:LLVMTypeRef 25 | safe:LLVMValueRef 26 | _non-null-string -> 27 | (ptr : _pointer) -> 28 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 29 | 30 | 31 | (define safe:free 32 | (_fun (builder : safe:LLVMBuilderRef) 33 | safe:LLVMValueRef -> 34 | (ptr : _pointer) -> 35 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 36 | 37 | (define safe:load 38 | (_fun (builder : safe:LLVMBuilderRef) 39 | safe:LLVMValueRef 40 | _non-null-string -> 41 | (ptr : _pointer) -> 42 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 43 | 44 | 45 | (define safe:store 46 | (_fun (builder : safe:LLVMBuilderRef) 47 | safe:LLVMValueRef 48 | safe:LLVMValueRef -> 49 | (ptr : _pointer) -> 50 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 51 | 52 | (define safe:gep 53 | (_fun (builder ptr indices name) :: 54 | (builder : safe:LLVMBuilderRef) 55 | (ptr : safe:LLVMValueRef) 56 | (indices : (_list i safe:LLVMValueRef)) 57 | (_uint = (length indices)) 58 | (name : _non-null-string) -> 59 | (ptr : _pointer) -> 60 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 61 | 62 | (define safe:struct-gep 63 | (_fun (builder : safe:LLVMBuilderRef) 64 | (ptr : safe:LLVMValueRef) 65 | (index : _uint) 66 | (name : _non-null-string) -> 67 | (ptr : _pointer) -> 68 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 69 | 70 | (define safe:string-builder 71 | (_fun (builder : safe:LLVMBuilderRef) 72 | (val : _string) 73 | (name : _non-null-string) -> 74 | (ptr : _pointer) -> 75 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 76 | 77 | 78 | ;/* Memory */ 79 | (define-llvm-multiple-unsafe 80 | (LLVMBuildMalloc 81 | LLVMBuildAlloca) 82 | (_fun LLVMBuilderRef LLVMTypeRef _string -> LLVMValueRef)) 83 | (define-llvm-multiple-unsafe 84 | (LLVMBuildArrayMalloc 85 | LLVMBuildArrayAlloca) 86 | (_fun LLVMBuilderRef LLVMTypeRef LLVMValueRef _string -> LLVMValueRef)) 87 | 88 | (define-llvm-unsafe LLVMBuildFree (_fun LLVMBuilderRef LLVMValueRef -> LLVMValueRef)) 89 | 90 | (define-llvm-unsafe LLVMBuildLoad 91 | (_fun LLVMBuilderRef LLVMValueRef _string -> LLVMValueRef)) 92 | (define-llvm-unsafe LLVMBuildStore 93 | (_fun LLVMBuilderRef LLVMValueRef LLVMValueRef -> LLVMValueRef)) 94 | 95 | (define-llvm-multiple-unsafe 96 | (LLVMBuildGEP 97 | LLVMBuildInBoundsGEP) 98 | (_fun (builder ptr indices name) :: 99 | (builder : LLVMBuilderRef) 100 | (ptr : LLVMValueRef) 101 | (indices : (_list i LLVMValueRef)) 102 | (_uint = (length indices)) 103 | (name : _string) 104 | -> LLVMValueRef)) 105 | 106 | 107 | (define-llvm-unsafe LLVMBuildStructGEP 108 | (_fun LLVMBuilderRef LLVMValueRef _uint _string -> LLVMValueRef)) 109 | 110 | (define-llvm-multiple-unsafe 111 | (LLVMBuildGlobalString LLVMBuildGlobalStringPtr) 112 | (_fun LLVMBuilderRef _string _string -> LLVMValueRef)) 113 | 114 | 115 | (define-llvm-multiple-safe 116 | (LLVMBuildMalloc LLVMBuildAlloca) 117 | safe:alloc) 118 | 119 | (define-llvm-multiple-safe (LLVMBuildArrayMalloc LLVMBuildArrayAlloca) safe:array-alloc) 120 | 121 | (define-llvm-safe LLVMBuildFree safe:free) 122 | 123 | (define-llvm-safe LLVMBuildLoad safe:load) 124 | (define-llvm-safe LLVMBuildStore safe:store) 125 | 126 | (define-llvm-multiple-safe (LLVMBuildGEP LLVMBuildInBoundsGEP) safe:gep) 127 | 128 | 129 | (define-llvm-safe LLVMBuildStructGEP safe:struct-gep) 130 | 131 | (define-llvm-multiple-safe 132 | (LLVMBuildGlobalString LLVMBuildGlobalStringPtr) 133 | safe:string-builder) 134 | 135 | -------------------------------------------------------------------------------- /private/ffi/misc-instructions.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "define.rkt" 5 | "ctypes.rkt") 6 | 7 | (require ffi/unsafe) 8 | 9 | (provide (all-defined-out)) 10 | 11 | ;/* Miscellaneous instructions */ 12 | 13 | (define-llvm-unsafe LLVMBuildPhi (_fun LLVMBuilderRef LLVMTypeRef _string -> LLVMValueRef)) 14 | 15 | 16 | (define-llvm-safe LLVMBuildPhi 17 | (_fun (builder : safe:LLVMBuilderRef) 18 | safe:LLVMTypeRef 19 | _non-null-string -> 20 | (ptr : _pointer) -> 21 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 22 | 23 | 24 | (define-llvm-unsafe LLVMBuildCall 25 | (_fun (builder fun args name) :: 26 | (builder : LLVMBuilderRef) 27 | (fun : LLVMValueRef) 28 | (args : (_list i LLVMValueRef)) 29 | (_uint = (length args)) 30 | (name : _string) 31 | -> LLVMValueRef)) 32 | 33 | 34 | (define-llvm-safe LLVMBuildCall 35 | (_fun (builder fun args name) :: 36 | (builder : safe:LLVMBuilderRef) 37 | (fun : safe:LLVMValueRef) 38 | (args : (_list i safe:LLVMValueRef)) 39 | (_uint = (length args)) 40 | (name : _non-null-string) -> 41 | (ptr : _pointer) -> 42 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 43 | 44 | 45 | 46 | 47 | (define-llvm-unsafe LLVMBuildSelect 48 | (_fun LLVMBuilderRef LLVMValueRef LLVMValueRef LLVMValueRef _string -> LLVMValueRef)) 49 | 50 | (define-llvm-unsafe LLVMBuildVAArg 51 | (_fun LLVMBuilderRef LLVMValueRef LLVMTypeRef _string -> LLVMValueRef)) 52 | 53 | (define-llvm-unsafe LLVMBuildExtractElement 54 | (_fun LLVMBuilderRef LLVMValueRef LLVMValueRef _string -> LLVMValueRef)) 55 | (define-llvm-unsafe LLVMBuildInsertElement 56 | (_fun LLVMBuilderRef LLVMValueRef LLVMValueRef LLVMValueRef _string -> LLVMValueRef)) 57 | 58 | 59 | (define-llvm-safe LLVMBuildExtractElement 60 | (_fun (builder : safe:LLVMBuilderRef) 61 | safe:LLVMValueRef 62 | safe:LLVMValueRef 63 | _non-null-string -> 64 | (ptr : _pointer) -> 65 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 66 | 67 | (define-llvm-safe LLVMBuildInsertElement 68 | (_fun (builder : safe:LLVMBuilderRef) 69 | safe:LLVMValueRef 70 | safe:LLVMValueRef 71 | safe:LLVMValueRef 72 | _non-null-string -> 73 | (ptr : _pointer) -> 74 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 75 | 76 | 77 | 78 | (define-llvm-unsafe LLVMBuildShuffleVector 79 | (_fun LLVMBuilderRef LLVMValueRef LLVMValueRef LLVMValueRef _string -> LLVMValueRef)) 80 | 81 | (define-llvm-unsafe LLVMBuildExtractValue 82 | (_fun LLVMBuilderRef LLVMValueRef _uint _string -> LLVMValueRef)) 83 | (define-llvm-unsafe LLVMBuildInsertValue 84 | (_fun LLVMBuilderRef LLVMValueRef LLVMValueRef _uint _string -> LLVMValueRef)) 85 | 86 | (define-llvm-safe LLVMBuildExtractValue 87 | (_fun (builder : safe:LLVMBuilderRef) 88 | safe:LLVMValueRef 89 | _uint 90 | _non-null-string -> 91 | (ptr : _pointer) -> 92 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 93 | (define-llvm-safe LLVMBuildInsertValue 94 | (_fun (builder : safe:LLVMBuilderRef) 95 | safe:LLVMValueRef 96 | safe:LLVMValueRef 97 | _uint 98 | _non-null-string -> 99 | (ptr : _pointer) -> 100 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 101 | 102 | 103 | 104 | (define-llvm-multiple-unsafe 105 | (LLVMBuildIsNull 106 | LLVMBuildIsNotNull) 107 | (_fun LLVMBuilderRef LLVMValueRef _string -> LLVMValueRef)) 108 | 109 | (define-llvm-unsafe LLVMBuildPtrDiff (_fun LLVMBuilderRef LLVMValueRef LLVMValueRef _string -> LLVMValueRef)) 110 | 111 | -------------------------------------------------------------------------------- /private/ffi/misc-operations.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "define.rkt" 5 | "ctypes.rkt") 6 | 7 | (require ffi/unsafe) 8 | 9 | (provide (all-defined-out)) 10 | 11 | ;/*===-- Values ------------------------------------------------------------===*/ 12 | 13 | ;/* The bulk of LLVM's object model consists of values, which comprise a very 14 | ; * rich type hierarchy. 15 | ; */ 16 | 17 | #| 18 | #define LLVM_FOR_EACH_VALUE_SUBCLASS(macro) \ 19 | macro(Argument) \ 20 | macro(BasicBlock) \ 21 | macro(InlineAsm) \ 22 | macro(User) \ 23 | macro(Constant) \ 24 | macro(ConstantAggregateZero) \ 25 | macro(ConstantArray) \ 26 | macro(ConstantExpr) \ 27 | macro(ConstantFP) \ 28 | macro(ConstantInt) \ 29 | macro(ConstantPointerNull) \ 30 | macro(ConstantStruct) \ 31 | macro(ConstantVector) \ 32 | macro(GlobalValue) \ 33 | macro(Function) \ 34 | macro(GlobalAlias) \ 35 | macro(GlobalVariable) \ 36 | macro(UndefValue) \ 37 | macro(Instruction) \ 38 | macro(BinaryOperator) \ 39 | macro(CallInst) \ 40 | macro(IntrinsicInst) \ 41 | macro(DbgInfoIntrinsic) \ 42 | macro(DbgDeclareInst) \ 43 | macro(EHSelectorInst) \ 44 | macro(MemIntrinsic) \ 45 | macro(MemCpyInst) \ 46 | macro(MemMoveInst) \ 47 | macro(MemSetInst) \ 48 | macro(CmpInst) \ 49 | macro(FCmpInst) \ 50 | macro(ICmpInst) \ 51 | macro(ExtractElementInst) \ 52 | macro(GetElementPtrInst) \ 53 | macro(InsertElementInst) \ 54 | macro(InsertValueInst) \ 55 | macro(LandingPadInst) \ 56 | macro(PHINode) \ 57 | macro(SelectInst) \ 58 | macro(ShuffleVectorInst) \ 59 | macro(StoreInst) \ 60 | macro(TerminatorInst) \ 61 | macro(BranchInst) \ 62 | macro(InvokeInst) \ 63 | macro(ReturnInst) \ 64 | macro(SwitchInst) \ 65 | macro(UnreachableInst) \ 66 | macro(ResumeInst) \ 67 | macro(UnaryInstruction) \ 68 | macro(AllocaInst) \ 69 | macro(CastInst) \ 70 | macro(BitCastInst) \ 71 | macro(FPExtInst) \ 72 | macro(FPToSIInst) \ 73 | macro(FPToUIInst) \ 74 | macro(FPTruncInst) \ 75 | macro(IntToPtrInst) \ 76 | macro(PtrToIntInst) \ 77 | macro(SExtInst) \ 78 | macro(SIToFPInst) \ 79 | macro(TruncInst) \ 80 | macro(UIToFPInst) \ 81 | macro(ZExtInst) \ 82 | macro(ExtractValueInst) \ 83 | macro(LoadInst) \ 84 | macro(VAArgInst) 85 | |# 86 | ;/* Operations on all values */ 87 | (define-llvm-unsafe LLVMTypeOf (_fun LLVMValueRef -> LLVMTypeRef)) 88 | 89 | 90 | (define-llvm-safe LLVMTypeOf 91 | (_fun (v : safe:LLVMValueRef) -> 92 | (ptr : _pointer) -> 93 | (safe:llvm-type-ref ptr 94 | (let ((o (safe:llvm-value-ref-owner v))) 95 | (if (safe:llvm-context-ref? o) 96 | o 97 | (safe:llvm-module-ref-context o)))))) 98 | 99 | 100 | (define-llvm-unsafe LLVMGetValueName (_fun LLVMValueRef -> _string)) 101 | 102 | (define-llvm-unsafe LLVMSetValueName (_fun LLVMValueRef _string -> _void)) 103 | (define-llvm-safe LLVMSetValueName (_fun safe:LLVMValueRef _non-null-string -> _void)) 104 | 105 | (define-llvm-unsafe LLVMDumpValue (_fun LLVMValueRef -> _void)) 106 | (define-llvm-unsafe LLVMReplaceAllUsesWith (_fun LLVMValueRef LLVMValueRef -> _void)) 107 | (define-llvm-unsafe LLVMHasMetadata (_fun LLVMValueRef -> _int)) 108 | (define-llvm-unsafe LLVMGetMetadata (_fun LLVMValueRef _uint -> LLVMValueRef)) 109 | (define-llvm-unsafe LLVMSetMetadata (_fun LLVMValueRef _uint LLVMValueRef -> _void)) 110 | 111 | 112 | ;/* Conversion functions. Return the input value if it is an instance of the 113 | ; specified class, otherwise NULL. See llvm::dyn_cast_or_null<>. */ 114 | #| 115 | #define LLVM_DECLARE_VALUE_CAST(name) \ 116 | LLVMValueRef LLVMIsA##name(LLVMValueRef Val); 117 | LLVM_FOR_EACH_VALUE_SUBCLASS(LLVM_DECLARE_VALUE_CAST) 118 | |# 119 | 120 | ;/* Operations on Uses */ 121 | (define-llvm-unsafe LLVMGetFirstUse (_fun LLVMValueRef -> LLVMUseRef)) 122 | (define-llvm-unsafe LLVMGetNextUse (_fun LLVMUseRef -> LLVMUseRef)) 123 | (define-llvm-multiple-unsafe 124 | (LLVMGetUser LLVMGetUsedValue) 125 | (_fun LLVMUseRef -> LLVMValueRef)) 126 | 127 | ;/* Operations on Users */ 128 | (define-llvm-unsafe LLVMGetOperand (_fun LLVMValueRef _uint -> LLVMValueRef)) 129 | (define-llvm-unsafe LLVMSetOperand (_fun LLVMValueRef _uint LLVMValueRef -> _void)) 130 | (define-llvm-unsafe LLVMGetNumOperands (_fun LLVMValueRef -> _int)) 131 | 132 | 133 | (define-llvm-multiple-unsafe 134 | (LLVMIsConstant 135 | LLVMIsNull 136 | LLVMIsUndef) 137 | (_fun LLVMValueRef -> LLVMBool)) 138 | 139 | 140 | (define-llvm-multiple-safe 141 | (LLVMIsConstant 142 | LLVMIsNull 143 | LLVMIsUndef) 144 | (_fun safe:LLVMValueRef -> LLVMBool)) 145 | 146 | 147 | ;/* Operations on metadata */ 148 | (define-llvm-unsafe LLVMMDStringInContext 149 | (_fun LLVMContextRef _string _uint -> LLVMValueRef)) 150 | (define-llvm-unsafe LLVMMDString 151 | (_fun _string _uint -> LLVMValueRef)) 152 | 153 | (define-llvm-unsafe LLVMMDNodeInContext 154 | (_fun LLVMContextRef LLVMValueRef _uint -> LLVMValueRef)) 155 | (define-llvm-unsafe LLVMMDNode 156 | (_fun LLVMValueRef _uint -> LLVMValueRef)) 157 | 158 | -------------------------------------------------------------------------------- /private/ffi/module-io.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "define.rkt" 5 | "ctypes.rkt") 6 | 7 | (require ffi/unsafe) 8 | 9 | (provide (all-defined-out)) 10 | 11 | ;/*===-- Operations on modules ---------------------------------------------===*/ 12 | 13 | ;/** Writes a module to the specified path. Returns 0 on success. */ 14 | (define-llvm-unsafe LLVMWriteBitcodeToFile (_fun LLVMModuleRef _string -> _int)) 15 | 16 | 17 | ;/** Writes a module to the specified path. Returns 0 on success. */ 18 | (define-llvm-safe LLVMWriteBitcodeToFile (_fun safe:LLVMModuleRef _string -> _int)) 19 | 20 | 21 | ;/** Writes a module to an open file descriptor. Returns 0 on success. */ 22 | (define-llvm-unsafe LLVMWriteBitcodeToFD (_fun LLVMModuleRef _int _bool _bool -> _int)) 23 | 24 | ;/* Builds a module from the bitcode in the specified memory buffer, returning a 25 | ; reference to the module via the OutModule parameter. Returns 0 on success. 26 | ; Optionally returns a human-readable error message via OutMessage. */ 27 | (define-llvm-unsafe LLVMParseBitcode 28 | (_fun (buffer) :: 29 | (buffer : LLVMMemoryBufferRef) 30 | (module : (_ptr o LLVMModuleRef)) 31 | (message : (_ptr io LLVMMessage) = #f) 32 | -> 33 | (err : LLVMBool) 34 | -> 35 | (if err message module))) 36 | 37 | (define-llvm-unsafe LLVMParseBitcodeInContext 38 | (_fun (context buffer) :: 39 | (context : LLVMContextRef) 40 | (buffer : LLVMMemoryBufferRef) 41 | (module : (_ptr o LLVMModuleRef)) 42 | (message : (_ptr io LLVMMessage) = #f) 43 | -> 44 | (err : LLVMBool) 45 | -> 46 | (if err message module))) 47 | 48 | (define-llvm-safe LLVMParseBitcodeInContext 49 | safe:LLVMModuleCreatorFromBitcode) 50 | 51 | 52 | (define-llvm-unsafe LLVMGetBitcodeModule 53 | (_fun (buffer) :: 54 | (buffer : LLVMMemoryBufferRef) 55 | (module : (_ptr o LLVMModuleRef)) 56 | (message : (_ptr io LLVMMessage) = #f) 57 | -> 58 | (err : LLVMBool) 59 | -> 60 | (if err message module))) 61 | 62 | (define-llvm-unsafe LLVMGetBitcodeModuleInContext 63 | (_fun (context buffer) :: 64 | (context : LLVMContextRef) 65 | (buffer : LLVMMemoryBufferRef) 66 | (module : (_ptr o LLVMModuleRef)) 67 | (message : (_ptr io LLVMMessage) = #f) 68 | -> 69 | (err : LLVMBool) 70 | -> 71 | (if err message module))) 72 | 73 | -------------------------------------------------------------------------------- /private/ffi/modules.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "define.rkt" 5 | "ctypes.rkt") 6 | 7 | (require ffi/unsafe) 8 | 9 | (provide (all-defined-out)) 10 | 11 | 12 | 13 | ;/*===-- Contexts ----------------------------------------------------------===*/ 14 | 15 | 16 | ;/* Create and destroy contexts. */ 17 | (define-llvm LLVMContextCreate 18 | #:unsafe (_fun -> LLVMContextRef) 19 | #:safe safe:LLVMContextCreator) 20 | 21 | 22 | (define-llvm-unsafe LLVMGetGlobalContext (_fun -> LLVMContextRef)) 23 | (define-llvm-unsafe LLVMContextDispose (_fun LLVMContextRef -> _void)) 24 | ;TODO why have this function 25 | (define (safe:LLVMContextDispose ctx) (void)) 26 | 27 | (define-llvm LLVMGetMDKindIDInContext 28 | #:both (_fun LLVMContextRef _string _uint -> _uint)) 29 | 30 | (define-llvm-unsafe LLVMGetMDKindID (_fun _string _uint -> _uint)) 31 | 32 | 33 | ;/*===-- Modules -----------------------------------------------------------===*/ 34 | 35 | ;/* Create and destroy modules. */ 36 | ;/** See llvm::Module::Module. */ 37 | (define-llvm-unsafe LLVMModuleCreateWithName (_fun _string -> LLVMModuleRef)) 38 | (define-llvm LLVMModuleCreateWithNameInContext 39 | #:unsafe (_fun _string LLVMContextRef -> LLVMModuleRef) 40 | #:safe safe:LLVMModuleCreator) 41 | 42 | 43 | ;/** See llvm::Module::~Module. */ 44 | (define-llvm-unsafe LLVMDisposeModule (_fun LLVMModuleRef -> _void)) 45 | ;TODO why have this function 46 | (define (safe:LLVMDisposeModule module) (void)) 47 | 48 | 49 | ;/** Data layout. See Module::getDataLayout. */ 50 | (define-llvm-unsafe LLVMGetDataLayout (_fun LLVMModuleRef -> _string)) 51 | (define-llvm-unsafe LLVMSetDataLayout (_fun LLVMModuleRef _string -> _void)) 52 | 53 | ;/** Target triple. See Module::getTargetTriple. */ 54 | (define-llvm LLVMGetTarget 55 | #:both (_fun LLVMModuleRef -> _string)) 56 | (define-llvm LLVMSetTarget 57 | #:both (_fun LLVMModuleRef _string -> _void)) 58 | 59 | ;/** See Module::dump. */ 60 | (define-llvm-unsafe LLVMDumpModule (_fun LLVMModuleRef -> _void)) 61 | 62 | ;/** See Module::setModuleInlineAsm. */ 63 | (define-llvm-unsafe LLVMSetModuleInlineAsm (_fun LLVMModuleRef _string -> _void)) 64 | 65 | ;/** See Module::getContext. */ 66 | (define-llvm-unsafe LLVMGetModuleContext (_fun LLVMModuleRef -> LLVMContextRef)) 67 | 68 | 69 | 70 | -------------------------------------------------------------------------------- /private/ffi/passes.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "define.rkt" 5 | "ctypes.rkt") 6 | 7 | (require ffi/unsafe) 8 | 9 | (provide (all-defined-out)) 10 | 11 | 12 | 13 | ;/*===-- Pass Registry -----------------------------------------------------===*/ 14 | 15 | ;/** Return the global pass registry, for use with initialization functions. 16 | ; See llvm::PassRegistry::getPassRegistry. */ 17 | (define-llvm-unsafe LLVMGetGlobalPassRegistry 18 | (_fun -> LLVMPassRegistryRef)) 19 | 20 | 21 | ;/*===-- Pass Managers -----------------------------------------------------===*/ 22 | 23 | ;/** Constructs a new whole-module pass pipeline. This type of pipeline is 24 | ; suitable for link-time optimization and whole-module transformations. 25 | ; See llvm::PassManager::PassManager. */ 26 | (define-llvm-unsafe LLVMCreatePassManager (_fun -> LLVMPassManagerRef)) 27 | 28 | ;/** Constructs a new function-by-function pass pipeline over the module 29 | ; provider. It does not take ownership of the module provider. This type of 30 | ; pipeline is suitable for code generation and JIT compilation tasks. 31 | ; See llvm::FunctionPassManager::FunctionPassManager. */ 32 | (define-llvm-unsafe LLVMCreateFunctionPassManagerForModule (_fun LLVMModuleRef -> LLVMPassManagerRef)) 33 | 34 | 35 | ;/** Initializes, executes on the provided module, and finalizes all of the 36 | ; passes scheduled in the pass manager. Returns 1 if any of the passes 37 | ; modified the module, 0 otherwise. See llvm::PassManager::run(Module&). */ 38 | (define-llvm-unsafe LLVMRunPassManager (_fun LLVMPassManagerRef LLVMModuleRef -> LLVMBool)) 39 | 40 | ;/** Initializes all of the function passes scheduled in the function pass 41 | ; manager. Returns 1 if any of the passes modified the module, 0 otherwise. 42 | ; See llvm::FunctionPassManager::doInitialization. */ 43 | (define-llvm-unsafe LLVMInitializeFunctionPassManager (_fun LLVMPassManagerRef -> LLVMBool)) 44 | 45 | ;/** Executes all of the function passes scheduled in the function pass manager 46 | ; on the provided function. Returns 1 if any of the passes modified the 47 | ; function, false otherwise. 48 | ; See llvm::FunctionPassManager::run(Function&). */ 49 | (define-llvm-unsafe LLVMRunFunctionPassManager (_fun LLVMPassManagerRef LLVMValueRef -> LLVMBool)) 50 | 51 | ;/** Finalizes all of the function passes scheduled in in the function pass 52 | ; manager. Returns 1 if any of the passes modified the module, 0 otherwise. 53 | ; See llvm::FunctionPassManager::doFinalization. */ 54 | (define-llvm-unsafe LLVMFinalizeFunctionPassManager (_fun LLVMPassManagerRef -> LLVMBool)) 55 | 56 | ;/** Frees the memory of a pass pipeline. For function pipelines, does not free 57 | ; the module provider. 58 | ; See llvm::PassManagerBase::~PassManagerBase. */ 59 | (define-llvm-unsafe LLVMDisposePassManager (_fun LLVMPassManagerRef -> _void)) 60 | 61 | 62 | ;Analysis 63 | (define LLVMVerifierFailureAction (_enum '( 64 | LLVMAbortProcessAction ;/* verifier will print to stderr and abort() */ 65 | LLVMPrintMessageAction ;/* verifier will print to stderr and return 1 */ 66 | LLVMReturnStatusAction))) ;/* verifier will just return 1 */ 67 | 68 | 69 | ;/* Verifies that a module is valid, taking the specified action if not. 70 | ; Optionally returns a human-readable description of any invalid constructs. 71 | ; OutMessage must be disposed with LLVMDisposeMessage. */ 72 | 73 | (define-llvm-unsafe LLVMVerifyModule 74 | (_fun (module action) :: 75 | (module : LLVMModuleRef) 76 | (action : LLVMVerifierFailureAction) 77 | (message : (_ptr io LLVMMessage) = #f) 78 | -> 79 | (ans : LLVMBool) 80 | -> 81 | (and ans message))) 82 | 83 | 84 | (define-llvm-safe LLVMVerifyModule 85 | (_fun (module action) :: 86 | (module : safe:LLVMModuleRef) 87 | (action : LLVMVerifierFailureAction) 88 | (message : (_ptr io LLVMMessage) = #f) 89 | -> 90 | (ans : LLVMBool) 91 | -> 92 | (and ans message))) 93 | 94 | 95 | 96 | ;/* Verifies that a single function is valid, taking the specified action. Useful 97 | ; for debugging. */ 98 | (define-llvm-unsafe LLVMVerifyFunction (_fun LLVMValueRef LLVMVerifierFailureAction -> LLVMBool)) 99 | 100 | ;/* Open up a ghostview window that displays the CFG of the current function. 101 | ; Useful for debugging. */ 102 | 103 | (define-llvm-unsafe LLVMViewFunctionCFG (_fun LLVMValueRef -> _void)) 104 | (define-llvm-unsafe LLVMViewFunctionCFGOnly (_fun LLVMValueRef -> _void)) 105 | 106 | 107 | (define-llvm-unsafe LLVMInitializeCore (_fun LLVMPassRegistryRef -> _void)) 108 | 109 | -------------------------------------------------------------------------------- /private/ffi/paths.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/runtime-path) 4 | (require (for-syntax racket/base)) 5 | (provide llvm-racket-lib-path) 6 | 7 | (define-runtime-path llvm-racket-lib-path (string-append "../../llvm-racket" (bytes->string/utf-8 (system-type 'so-suffix)))) 8 | -------------------------------------------------------------------------------- /private/ffi/racket-ext.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "define.rkt" 5 | "ctypes.rkt") 6 | 7 | (require ffi/unsafe) 8 | 9 | (provide (except-out (all-defined-out) safe:type-at-index)) 10 | 11 | 12 | ;Racket added functions 13 | ; 14 | 15 | (define-llvm-racket-unsafe LLVMGetModuleDescription unsafe:LLVMModuleDescriptionMaker) 16 | (define-llvm-racket-unsafe LLVMIsValidTypeIndex (_fun LLVMTypeRef LLVMValueRef -> LLVMBool)) 17 | (define-llvm-racket-unsafe LLVMGetTypeAtIndex (_fun LLVMTypeRef LLVMValueRef -> LLVMTypeRef)) 18 | (define-llvm-racket-unsafe LLVMIsTerminatorInstruction (_fun LLVMValueRef -> LLVMBool)) 19 | 20 | 21 | (define safe:type-at-index 22 | (_fun (ty : safe:LLVMTypeRef) 23 | safe:LLVMValueRef -> 24 | (ptr : _pointer) -> 25 | (safe:llvm-type-ref ptr (safe:llvm-type-ref-context ty)))) 26 | 27 | (define safe:is-valid-type-index 28 | (_fun safe:LLVMTypeRef 29 | safe:LLVMValueRef -> 30 | LLVMBool)) 31 | 32 | 33 | 34 | (define-llvm-racket-safe LLVMGetTypeAtIndex safe:type-at-index) 35 | (define-llvm-racket-safe LLVMIsValidTypeIndex safe:is-valid-type-index) 36 | (define-llvm-racket-safe LLVMIsTerminatorInstruction (_fun safe:LLVMValueRef -> LLVMBool)) 37 | (define-llvm-racket-safe LLVMGetModuleDescription safe:LLVMModuleDescriptionMaker) 38 | 39 | (define-llvm-racket-safe LLVMOptimizeModule (_fun safe:LLVMModuleRef -> LLVMBool)) 40 | 41 | -------------------------------------------------------------------------------- /private/ffi/runtime.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "lib.rkt" 5 | "define.rkt" 6 | "ctypes.rkt") 7 | 8 | (require ffi/unsafe) 9 | 10 | (provide (all-defined-out)) 11 | 12 | ;Execution Engine 13 | 14 | (define-llvm-multiple-unsafe (LLVMLinkInJIT LLVMLinkInInterpreter) (_fun -> _void)) 15 | 16 | 17 | ;/*===-- Operations on generic values --------------------------------------===*/ 18 | 19 | (define-llvm-unsafe LLVMCreateGenericValueOfInt 20 | (_fun LLVMTypeRef _ulong LLVMBool -> LLVMGenericValueRef)) 21 | 22 | (define-llvm-unsafe LLVMCreateGenericValueOfPointer 23 | (_fun _pointer -> LLVMGenericValueRef)) 24 | 25 | (define (unsafe:LLVMCreateGenericValueOfFunctionType fun-type) 26 | (with-llvm-safety #:unsafe 27 | (get-ffi-obj 'LLVMCreateGenericValueOfPointer llvm-lib 28 | (_fun fun-type -> LLVMGenericValueRef)))) 29 | 30 | (define-llvm-unsafe LLVMCreateGenericValueOfFloat 31 | (_fun LLVMTypeRef _double* -> LLVMGenericValueRef)) 32 | 33 | (define-llvm-unsafe LLVMGenericValueIntWidth 34 | (_fun LLVMGenericValueRef -> _uint)) 35 | 36 | (define-llvm-unsafe LLVMGenericValueToInt 37 | (_fun LLVMGenericValueRef LLVMBool -> _long)) 38 | 39 | (define-llvm-unsafe LLVMGenericValueToPointer 40 | (_fun LLVMGenericValueRef -> _pointer)) 41 | 42 | (define-llvm-unsafe LLVMGenericValueToFloat 43 | (_fun LLVMTypeRef LLVMGenericValueRef -> _double*)) 44 | 45 | (define-llvm-unsafe LLVMDisposeGenericValue 46 | (_fun LLVMGenericValueRef -> _void)) 47 | 48 | 49 | (define-llvm-safe LLVMCreateGenericValueOfInt 50 | (_fun safe:LLVMTypeRef _ulong LLVMBool -> safe:LLVMGenericValueRef)) 51 | 52 | (define-llvm-safe LLVMCreateGenericValueOfPointer 53 | (_fun _pointer -> safe:LLVMGenericValueRef)) 54 | 55 | (define (safe:LLVMCreateGenericValueOfFunctionType fun-type) 56 | (get-ffi-obj 'LLVMCreateGenericValueOfPointer llvm-lib 57 | (_fun fun-type -> safe:LLVMGenericValueRef))) 58 | 59 | (define-llvm-safe LLVMCreateGenericValueOfFloat 60 | (_fun safe:LLVMTypeRef _double* -> safe:LLVMGenericValueRef)) 61 | 62 | (define-llvm-safe LLVMGenericValueIntWidth 63 | (_fun safe:LLVMGenericValueRef -> _uint)) 64 | 65 | (define-llvm-safe LLVMGenericValueToInt 66 | (_fun safe:LLVMGenericValueRef LLVMBool -> _long)) 67 | 68 | (define-llvm-safe LLVMGenericValueToPointer 69 | (_fun safe:LLVMGenericValueRef -> _pointer)) 70 | 71 | (define-llvm-safe LLVMGenericValueToFloat 72 | (_fun safe:LLVMTypeRef safe:LLVMGenericValueRef -> _double*)) 73 | 74 | 75 | 76 | ;/*===-- Operations on execution engines -----------------------------------===*/ 77 | 78 | (define-llvm-unsafe LLVMCreateExecutionEngineForModule 79 | (_fun (module) :: 80 | (execution-engine : (_ptr o LLVMExecutionEngineRef)) 81 | (module : LLVMModuleRef) 82 | (message : (_ptr io LLVMMessage) = #f) 83 | -> 84 | (err : LLVMBool) 85 | -> 86 | (if err message execution-engine))) 87 | 88 | (define-llvm-unsafe LLVMCreateInterpreterForModule 89 | (_fun (module) :: 90 | (execution-engine : (_ptr o LLVMExecutionEngineRef)) 91 | (module : LLVMModuleRef) 92 | (message : (_ptr io LLVMMessage) = #f) 93 | -> 94 | (err : LLVMBool) 95 | -> 96 | (if err message execution-engine))) 97 | 98 | (define-llvm-unsafe LLVMCreateJITCompilerForModule 99 | (_fun (module opt) :: 100 | (execution-engine : (_ptr o LLVMExecutionEngineRef)) 101 | (module : LLVMModuleRef) 102 | (opt : _uint) 103 | (message : (_ptr io LLVMMessage) = #f) 104 | -> 105 | (err : LLVMBool) 106 | -> 107 | (if err message execution-engine))) 108 | 109 | 110 | (define-llvm-safe LLVMCreateExecutionEngineForModule 111 | safe:LLVMExecutionEngineCreator) 112 | 113 | (define-llvm-safe LLVMCreateJITCompilerForModule 114 | safe:LLVMJITCreator) 115 | 116 | 117 | (define-llvm-multiple-unsafe 118 | (LLVMDisposeExecutionEngine 119 | LLVMRunStaticConstructors 120 | LLVMRunStaticDestructors) 121 | (_fun LLVMExecutionEngineRef -> _void)) 122 | 123 | 124 | ;TODO support env 125 | (define-llvm-unsafe LLVMRunFunctionAsMain 126 | (_fun (ee fun args) :: 127 | (ee : LLVMExecutionEngineRef) 128 | (fun : LLVMValueRef) 129 | (_uint = (length args)) 130 | (args : (_list i _string)) 131 | (env : (_list i _string) = (list #f)) 132 | -> 133 | _sint)) 134 | 135 | 136 | (define-llvm-unsafe LLVMRunFunction 137 | (_fun (engine function args) :: 138 | (engine : LLVMExecutionEngineRef) 139 | (function : LLVMValueRef) 140 | (_uint = (length args)) 141 | (args : (_list i LLVMGenericValueRef)) 142 | -> 143 | LLVMGenericValueRef)) 144 | 145 | 146 | (define-llvm-safe LLVMRunFunction 147 | (_fun (engine function args) :: 148 | (engine : safe:LLVMExecutionEngineRef) 149 | (function : safe:LLVMValueRef) 150 | (_uint = (length args)) 151 | (args : (_list i safe:LLVMGenericValueRef)) 152 | -> 153 | safe:LLVMGenericValueRef)) 154 | 155 | (define safe:LLVMRunVoidFunction 156 | (let () 157 | (define-llvm-unsafe LLVMDisposeGenericValue 158 | (_fun _pointer -> _void)) 159 | (define-llvm-safe LLVMRunFunction 160 | (_fun (engine function args) :: 161 | (engine : safe:LLVMExecutionEngineRef) 162 | (function : safe:LLVMValueRef) 163 | (_uint = (length args)) 164 | (args : (_list i safe:LLVMGenericValueRef)) 165 | -> (ptr : _pointer) 166 | -> (unsafe:LLVMDisposeGenericValue ptr))) 167 | safe:LLVMRunFunction)) 168 | 169 | 170 | 171 | 172 | 173 | (define-llvm-unsafe LLVMAddModule (_fun LLVMExecutionEngineRef LLVMModuleRef -> _void)) 174 | 175 | (define-llvm-unsafe LLVMFreeMachineCodeForFunction 176 | (_fun LLVMExecutionEngineRef LLVMValueRef -> _void)) 177 | 178 | (define-llvm-unsafe LLVMRemoveModule 179 | (_fun (ee module) :: 180 | (ee : LLVMExecutionEngineRef) 181 | (module : LLVMModuleRef) 182 | (outmod : (_ptr o LLVMModuleRef)) 183 | (message : (_ptr io LLVMMessage) = #f) 184 | -> 185 | (err : LLVMBool) 186 | -> 187 | (if err message outmod))) 188 | 189 | (define-llvm-unsafe LLVMFindFunction 190 | (_fun (ee name) :: 191 | (ee : LLVMExecutionEngineRef) 192 | (name : _string) 193 | (outfun : (_ptr o LLVMValueRef)) 194 | -> (err : LLVMBool) 195 | -> (if err #f outfun))) 196 | 197 | 198 | (define-llvm-unsafe LLVMRecompileAndRelinkFunction 199 | (_fun LLVMExecutionEngineRef LLVMValueRef -> _pointer)) 200 | 201 | (define-llvm-unsafe LLVMGetExecutionEngineTargetData 202 | (_fun LLVMExecutionEngineRef -> LLVMTargetDataRef)) 203 | 204 | (define-llvm-unsafe LLVMAddGlobalMapping 205 | (_fun LLVMExecutionEngineRef LLVMValueRef _pointer -> _void)) 206 | 207 | ;TODO fix this 208 | #; 209 | (define (LLVMAddGlobalMappingForFunction fun-type) 210 | (get-ffi-obj 'LLVMAddGlobalMapping llvm-lib 211 | (_fun LLVMExecutionEngineRef LLVMValueRef fun-type -> LLVMGenericValueRef))) 212 | 213 | (define-llvm-unsafe LLVMGetPointerToGlobal 214 | (_fun LLVMExecutionEngineRef LLVMValueRef -> _pointer)) 215 | 216 | 217 | (define-llvm-safe LLVMGetPointerToGlobal 218 | (_fun safe:LLVMExecutionEngineRef safe:LLVMValueRef -> _pointer)) 219 | 220 | -------------------------------------------------------------------------------- /private/ffi/safe.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/require 4 | (for-syntax racket/base)) 5 | (require (filtered-in 6 | (lambda (name) 7 | (cond 8 | ((regexp-match #rx"^safe:(.*)$" name) => cadr) 9 | (else #f))) 10 | "all.rkt")) 11 | 12 | (provide (all-from-out "all.rkt")) 13 | -------------------------------------------------------------------------------- /private/ffi/terminators.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "define.rkt" 5 | "ctypes.rkt") 6 | 7 | (require ffi/unsafe) 8 | 9 | (provide (all-defined-out)) 10 | 11 | ;/* Terminators */ 12 | (define-llvm-unsafe LLVMBuildRetVoid (_fun LLVMBuilderRef -> LLVMValueRef)) 13 | (define-llvm-unsafe LLVMBuildRet (_fun LLVMBuilderRef LLVMValueRef -> LLVMValueRef)) 14 | 15 | (define-llvm-safe LLVMBuildRetVoid 16 | (_fun (builder : safe:LLVMBuilderRef) -> 17 | (ptr : _pointer) -> 18 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 19 | 20 | (define-llvm-safe LLVMBuildRet 21 | (_fun (builder : safe:LLVMBuilderRef) 22 | safe:LLVMValueRef -> 23 | (ptr : _pointer) -> 24 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 25 | 26 | 27 | (define-llvm-unsafe LLVMBuildAggregateRet 28 | (_fun (builder vals) :: 29 | (builder : LLVMBuilderRef) 30 | (vals : (_list i LLVMValueRef)) 31 | (_uint = (length vals)) 32 | -> LLVMValueRef)) 33 | 34 | 35 | (define-llvm-unsafe LLVMBuildBr (_fun LLVMBuilderRef LLVMBasicBlockRef -> LLVMValueRef)) 36 | 37 | (define-llvm-safe LLVMBuildBr 38 | (_fun (builder : safe:LLVMBuilderRef) 39 | safe:LLVMBasicBlockRef -> 40 | (ptr : _pointer) -> 41 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 42 | 43 | (define-llvm-unsafe LLVMBuildCondBr 44 | (_fun LLVMBuilderRef 45 | LLVMValueRef 46 | LLVMBasicBlockRef 47 | LLVMBasicBlockRef -> LLVMValueRef)) 48 | 49 | 50 | (define-llvm-safe LLVMBuildCondBr 51 | (_fun (builder : safe:LLVMBuilderRef) 52 | safe:LLVMValueRef 53 | safe:LLVMBasicBlockRef 54 | safe:LLVMBasicBlockRef -> 55 | (ptr : _pointer) -> 56 | (safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder)))) 57 | 58 | 59 | 60 | 61 | (define-llvm-unsafe LLVMBuildSwitch 62 | (_fun LLVMBuilderRef LLVMValueRef LLVMBasicBlockRef _uint -> LLVMValueRef)) 63 | 64 | (define-llvm-unsafe LLVMAddCase (_fun LLVMValueRef LLVMValueRef LLVMBasicBlockRef -> _void)) 65 | 66 | (define-llvm-unsafe LLVMBuildIndirectBr (_fun LLVMBuilderRef LLVMValueRef _uint -> LLVMValueRef)) 67 | (define-llvm-unsafe LLVMBuildInvoke 68 | (_fun (builder fun args then catch name) :: 69 | (builder : LLVMBuilderRef) 70 | (fun : LLVMValueRef) 71 | (args : (_list i LLVMValueRef)) 72 | (_uint = (length args)) 73 | (then : LLVMBasicBlockRef) 74 | (catch : LLVMBasicBlockRef) 75 | (name : _string) 76 | -> 77 | LLVMValueRef)) 78 | 79 | (define-llvm-unsafe LLVMBuildLandingPad 80 | (_fun LLVMBuilderRef 81 | LLVMTypeRef 82 | LLVMValueRef 83 | _uint 84 | _string 85 | -> _void)) 86 | (define-llvm-unsafe LLVMBuildResume 87 | (_fun LLVMBuilderRef LLVMValueRef -> LLVMValueRef)) 88 | 89 | (define-llvm-unsafe LLVMBuildUnreachable 90 | (_fun LLVMBuilderRef -> LLVMValueRef)) 91 | 92 | ;/* Add a destination to the indirectbr instruction */ 93 | (define-llvm-unsafe LLVMAddDestination (_fun LLVMValueRef LLVMBasicBlockRef -> _void)) 94 | 95 | (define-llvm-unsafe LLVMAddClause (_fun LLVMValueRef LLVMValueRef -> _void)) 96 | (define-llvm-unsafe LLVMSetCleanup (_fun LLVMValueRef LLVMBool -> _void)) 97 | -------------------------------------------------------------------------------- /private/ffi/types.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | 4 | (provide (all-defined-out)) 5 | (require "define.rkt" 6 | "ctypes.rkt" 7 | "enums.rkt" 8 | ffi/unsafe) 9 | 10 | ;/*===-- Types -------------------------------------------------------------===*/ 11 | 12 | ;/* LLVM types conform to the following hierarchy: 13 | ; * 14 | ; * types: 15 | ; * integer type 16 | ; * real type 17 | ; * function type 18 | ; * sequence types: 19 | ; * array type 20 | ; * pointer type 21 | ; * vector type 22 | ; * void type 23 | ; * label type 24 | ; * opaque type 25 | ; */ 26 | 27 | ;/** See llvm::LLVMTypeKind::getTypeID. */ 28 | (define-llvm-unsafe LLVMGetTypeKind (_fun LLVMTypeRef -> LLVMTypeKind)) 29 | (define-llvm-safe LLVMGetTypeKind (_fun safe:LLVMTypeRef -> LLVMTypeKind)) 30 | 31 | ;/** See llvm::LLVMType::getContext. */ 32 | (define-llvm-unsafe LLVMGetTypeContext (_fun LLVMTypeRef -> LLVMContextRef)) 33 | 34 | ;/* Operations on integer types */ 35 | 36 | (define safe:type-constructor 37 | (_fun (ctx : safe:LLVMContextRef) -> 38 | (ptr : _pointer) -> 39 | (safe:llvm-type-ref ptr ctx))) 40 | 41 | (define safe:type-converter 42 | (_fun (ty : safe:LLVMTypeRef) -> 43 | (ptr : _pointer) -> 44 | (safe:llvm-type-ref ptr (safe:llvm-type-ref-context ty)))) 45 | 46 | 47 | 48 | (define-llvm-multiple-unsafe 49 | (LLVMInt1TypeInContext 50 | LLVMInt8TypeInContext 51 | LLVMInt16TypeInContext 52 | LLVMInt32TypeInContext 53 | LLVMInt64TypeInContext) (_fun LLVMContextRef -> LLVMTypeRef)) 54 | 55 | 56 | (define-llvm-multiple-safe 57 | (LLVMInt1TypeInContext 58 | LLVMInt8TypeInContext 59 | LLVMInt16TypeInContext 60 | LLVMInt32TypeInContext 61 | LLVMInt64TypeInContext) safe:type-constructor) 62 | 63 | 64 | (define-llvm-unsafe LLVMIntTypeInContext (_fun LLVMContextRef _uint -> LLVMTypeRef)) 65 | 66 | (define-llvm-multiple-unsafe 67 | (LLVMInt1Type 68 | LLVMInt8Type 69 | LLVMInt16Type 70 | LLVMInt32Type 71 | LLVMInt64Type) (_fun -> LLVMTypeRef)) 72 | (define-llvm-unsafe LLVMIntType (_fun _uint -> LLVMTypeRef)) 73 | 74 | (define-llvm-unsafe LLVMGetIntTypeWidth (_fun LLVMTypeRef -> _uint)) 75 | (define-llvm-safe LLVMGetIntTypeWidth (_fun safe:LLVMTypeRef -> _uint)) 76 | 77 | ;/* Operations on real types */ 78 | (define-llvm-multiple-unsafe 79 | (LLVMFloatTypeInContext 80 | LLVMDoubleTypeInContext 81 | LLVMX86FP80TypeInContext 82 | LLVMFP128TypeInContext 83 | LLVMPPCFP128TypeInContext) (_fun LLVMContextRef -> LLVMTypeRef)) 84 | 85 | 86 | (define-llvm-multiple-safe 87 | (LLVMFloatTypeInContext 88 | LLVMDoubleTypeInContext 89 | LLVMX86FP80TypeInContext 90 | LLVMFP128TypeInContext 91 | LLVMPPCFP128TypeInContext) 92 | (_fun (ctx : safe:LLVMContextRef) -> 93 | (ptr : _pointer) -> 94 | (safe:llvm-type-ref ptr ctx))) 95 | 96 | 97 | (define-llvm-multiple-unsafe 98 | (LLVMFloatType 99 | LLVMDoubleType 100 | LLVMX86FP80Type 101 | LLVMFP128Type 102 | LLVMPPCFP128Type) (_fun -> LLVMTypeRef)) 103 | 104 | ;/* Operations on function types */ 105 | (define-llvm-unsafe LLVMFunctionType 106 | (_fun (ret-type arg-types varargs) :: 107 | (ret-type : LLVMTypeRef) 108 | (arg-types : (_list i LLVMTypeRef)) 109 | (_uint = (length arg-types)) 110 | (varargs : LLVMBool) 111 | -> LLVMTypeRef)) 112 | 113 | (define-llvm-safe LLVMFunctionType 114 | (_fun (ret-type arg-types varargs) :: 115 | (ret-type : safe:LLVMTypeRef) 116 | (arg-types : (_list i safe:LLVMTypeRef)) 117 | (_uint = (length arg-types)) 118 | (varargs : LLVMBool) -> 119 | (ptr : _pointer) -> 120 | (safe:llvm-type-ref ptr (safe:llvm-type-ref-context ret-type)))) 121 | 122 | 123 | 124 | 125 | (define-llvm-unsafe LLVMIsFunctionVarArg (_fun LLVMTypeRef -> LLVMBool)) 126 | (define-llvm-unsafe LLVMGetReturnType (_fun LLVMTypeRef -> LLVMTypeRef)) 127 | (define-llvm-unsafe LLVMCountParamTypes (_fun LLVMTypeRef -> _uint)) 128 | (define-llvm-unsafe LLVMGetParamTypes (_fun LLVMTypeRef _pointer -> _void)) 129 | 130 | 131 | (define-llvm-safe LLVMGetReturnType safe:type-converter) 132 | 133 | 134 | ;/* Operations on struct types */ 135 | (define-llvm-unsafe LLVMStructTypeInContext 136 | (_fun (context types packed) :: 137 | (context : LLVMContextRef) 138 | (types : (_list i LLVMTypeRef)) 139 | (_uint = (length types)) 140 | (packed : LLVMBool) 141 | -> LLVMTypeRef)) 142 | 143 | (define-llvm-unsafe LLVMStructType 144 | (_fun (types packed) :: 145 | (types : (_list i LLVMTypeRef)) 146 | (_uint = (length types)) 147 | (packed : LLVMBool) 148 | -> LLVMTypeRef)) 149 | 150 | (define-llvm-safe LLVMStructTypeInContext 151 | (_fun (context types packed) :: 152 | (context : safe:LLVMContextRef) 153 | (types : (_list i safe:LLVMTypeRef)) 154 | (_uint = (length types)) 155 | (packed : LLVMBool) -> 156 | (ptr : _pointer) -> 157 | (safe:llvm-type-ref ptr context))) 158 | 159 | 160 | 161 | 162 | (define-llvm-unsafe LLVMStructCreateNamed (_fun LLVMContextRef _string -> LLVMTypeRef)) 163 | (define-llvm-safe LLVMStructCreateNamed 164 | (_fun (ctx : safe:LLVMContextRef) 165 | _non-null-string -> 166 | (ptr : _pointer) -> 167 | (safe:llvm-type-ref ptr ctx))) 168 | 169 | (define-llvm-unsafe LLVMStructSetBody 170 | (_fun (type types packed) :: 171 | (type : LLVMTypeRef) 172 | (types : (_list i LLVMTypeRef)) 173 | (_uint = (length types)) 174 | (packed : LLVMBool) 175 | -> _void)) 176 | 177 | (define-llvm-safe LLVMStructSetBody 178 | (_fun (type types packed) :: 179 | (type : safe:LLVMTypeRef) 180 | (types : (_list i safe:LLVMTypeRef)) 181 | (_uint = (length types)) 182 | (packed : LLVMBool) 183 | -> _void)) 184 | 185 | 186 | 187 | (define-llvm-unsafe LLVMCountStructElementTypes (_fun LLVMTypeRef -> _uint)) 188 | 189 | (define-llvm-unsafe LLVMGetStructElementTypes 190 | (_fun (type) :: 191 | (type : LLVMTypeRef) 192 | (types : (_list o LLVMTypeRef (unsafe:LLVMCountStructElementTypes type))) 193 | -> _void 194 | -> types)) 195 | (define-llvm-unsafe LLVMIsPackedStruct (_fun LLVMTypeRef -> LLVMBool)) 196 | (define-llvm-unsafe LLVMIsOpaqueStruct (_fun LLVMTypeRef -> LLVMBool)) 197 | 198 | (define-llvm-unsafe LLVMGetTypeByName (_fun LLVMModuleRef _string -> LLVMTypeRef)) 199 | 200 | 201 | ;/* Operations on array, pointer, and vector types (sequence types) */ 202 | (define-llvm-multiple-unsafe 203 | (LLVMArrayType 204 | LLVMPointerType 205 | LLVMVectorType) (_fun LLVMTypeRef _uint -> LLVMTypeRef)) 206 | 207 | (define-llvm-multiple-safe 208 | (LLVMArrayType 209 | LLVMPointerType 210 | LLVMVectorType) 211 | (_fun (type : safe:LLVMTypeRef) 212 | _uint -> 213 | (ptr : _pointer) -> 214 | (safe:llvm-type-ref ptr (safe:llvm-type-ref-context type)))) 215 | 216 | 217 | 218 | (define-llvm-unsafe LLVMGetElementType (_fun LLVMTypeRef -> LLVMTypeRef)) 219 | (define-llvm-safe LLVMGetElementType safe:type-converter) 220 | 221 | (define-llvm-multiple-unsafe 222 | (LLVMGetArrayLength 223 | LLVMGetPointerAddressSpace 224 | LLVMGetVectorSize) (_fun LLVMTypeRef -> _uint)) 225 | 226 | 227 | (define-llvm-multiple-safe 228 | (LLVMGetArrayLength 229 | LLVMGetPointerAddressSpace 230 | LLVMGetVectorSize) (_fun safe:LLVMTypeRef -> _uint)) 231 | 232 | 233 | 234 | ;/* Operations on other types */ 235 | 236 | (define-llvm-multiple-unsafe 237 | (LLVMVoidTypeInContext 238 | LLVMLabelTypeInContext 239 | LLVMX86MMXTypeInContext) (_fun LLVMContextRef -> LLVMTypeRef)) 240 | 241 | 242 | (define-llvm-multiple-safe 243 | (LLVMVoidTypeInContext 244 | LLVMLabelTypeInContext 245 | LLVMX86MMXTypeInContext) 246 | (_fun (ctx : safe:LLVMContextRef) -> 247 | (ptr : _pointer) -> 248 | (safe:llvm-type-ref ptr ctx))) 249 | 250 | 251 | (define-llvm-multiple-unsafe 252 | (LLVMVoidType 253 | LLVMLabelType 254 | LLVMX86MMXType) (_fun -> LLVMTypeRef)) 255 | 256 | -------------------------------------------------------------------------------- /private/ffi/unsafe.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/require 4 | (for-syntax racket/base)) 5 | (require (filtered-in 6 | (lambda (name) 7 | (cond 8 | ((regexp-match #rx"^unsafe:(.*)$" name) => cadr) 9 | (else #f))) 10 | "all.rkt")) 11 | 12 | (provide (all-from-out "all.rkt")) 13 | -------------------------------------------------------------------------------- /private/llvm-config.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | (for-syntax racket/base syntax/parse) 5 | racket/string 6 | racket/port 7 | racket/promise 8 | racket/contract) 9 | 10 | 11 | (provide 12 | (contract-out 13 | (llvm-include-dir (-> string?)) 14 | (llvm-lib-dir (-> string?)) 15 | (llvm-version (-> string?)) 16 | (llvm-cpp-flags (-> (listof string?))))) 17 | 18 | (define-syntax (define/promise stx) 19 | (syntax-parse stx 20 | ((_ name:id body:expr) 21 | #'(begin 22 | (define p (delay body)) 23 | (define (name) (force p)))))) 24 | 25 | (define (llvm-config/list flag) 26 | (define (remove-blanks lst) 27 | (filter (lambda (x) (not (equal? x ""))) lst)) 28 | (remove-blanks (regexp-split " " (llvm-config flag)))) 29 | 30 | (define (llvm-config flag) 31 | (let-values (((process out in err) (subprocess #f #f #f "/usr/bin/env" "llvm-config" flag))) 32 | (close-output-port in) 33 | (begin0 34 | (string-trim (port->string out)) 35 | (close-input-port err) 36 | (close-input-port out) 37 | (subprocess-wait process) 38 | (unless (= (subprocess-status process) 0) 39 | (error 'llvm-config "Returned non zero exit code for flags: ~a" flag))))) 40 | 41 | 42 | 43 | (define/promise llvm-include-dir (llvm-config "--includedir")) 44 | (define/promise llvm-lib-dir (llvm-config "--libdir")) 45 | (define/promise llvm-version (llvm-config "--version")) 46 | (define/promise llvm-cpp-flags (llvm-config/list "--cppflags")) 47 | 48 | 49 | -------------------------------------------------------------------------------- /private/llvm-headers.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | (for-syntax racket/base) 5 | (rename-in racket/contract 6 | (-> c:->)) 7 | racket/port 8 | racket/match 9 | racket/list 10 | racket/string 11 | ffi/unsafe 12 | "clang.rkt" 13 | "llvm-config.rkt") 14 | 15 | (provide 16 | (contract-out 17 | (read-header (c:-> path-string? #:lang (or/c 'c 'c++) any/c)) 18 | (namespace-get-enum (c:-> namespace? symbol? (or/c (hash/c symbol? integer?) #f))) 19 | (namespace-get-typedef (c:-> namespace? symbol? (or/c (hash/c symbol? integer?) #f))) 20 | (namespace-get-namespace (c:-> namespace? symbol? (or/c namespace? #f))))) 21 | 22 | ;; Represents the enums, typedefs, and subname spaces of a namespace. 23 | ;; enums: (hash/c symbol? integer?) 24 | ;; typedefs: (hash/c symbol? integer?) 25 | ;; namespaces (hash/c symbol? namespace?) 26 | (struct namespace [enums typedefs namespaces] #:transparent) 27 | 28 | (define (read-header name #:lang lang) 29 | (define filename (string-append (llvm-include-dir) "/" name)) 30 | (define idx (create-index #:display-diagnostics #t)) 31 | (define tu (create-translation-unit-from-source-file idx filename 32 | (list* "-x" (symbol->string lang) (llvm-cpp-flags)))) 33 | 34 | ;; cursor -> (hash/c symbol? integer?) 35 | (define (read-enum-decl cursor) 36 | (make-immutable-hash 37 | (cursor-map cursor 38 | (λ (child) 39 | (cons (string->symbol (cursor-spelling child)) (enum-constant-decl-value child)))))) 40 | 41 | ;; cursor -> namespace 42 | (define (visit-cursor c) 43 | (define entries 44 | (cursor-map c 45 | (λ (cursor) 46 | (cond 47 | [(namespace-decl-cursor? cursor) 48 | (list 'namespace 49 | (string->symbol (cursor-spelling cursor)) 50 | (visit-cursor cursor))] 51 | [(typedef-decl-cursor? cursor) 52 | (define enum (cursor-find cursor read-enum-decl)) 53 | (and enum (list 'typedef (string->symbol (cursor-spelling cursor)) enum))] 54 | [(enum-decl-cursor? cursor) 55 | (define name (cursor-spelling cursor)) 56 | (and (not (equal? "" name)) 57 | (list 'enum (string->symbol name) (read-enum-decl cursor)))] 58 | [else #f])))) 59 | (namespace 60 | (for/hash ([entry (in-list entries)] 61 | #:when (and entry (equal? (first entry) 'enum))) 62 | (values (second entry) (third entry))) 63 | (for/hash ([entry (in-list entries)] 64 | #:when (and entry (equal? (first entry) 'typedef))) 65 | (values (second entry) (third entry))) 66 | (for/hash ([entry (in-list entries)] 67 | #:when (and entry (equal? (first entry) 'namespace))) 68 | (values (second entry) (third entry))))) 69 | 70 | (visit-cursor (translation-unit-cursor tu))) 71 | 72 | (define (namespace-get-typedef namespace name) 73 | (for/first ([(n v) (in-hash (namespace-typedefs namespace))] 74 | #:when (equal? name n)) 75 | v)) 76 | 77 | (define (namespace-get-enum namespace name) 78 | (for/first ([(n v) (in-hash (namespace-enums namespace))] 79 | #:when (equal? name n)) 80 | v)) 81 | 82 | (define (namespace-get-namespace namespace name) 83 | (for/first ([(n v) (in-hash (namespace-namespaces namespace))] 84 | #:when (equal? name n)) 85 | v)) 86 | -------------------------------------------------------------------------------- /private/llvm-util-exptime.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | (provide id-prefix) 4 | 5 | (: id-prefix (Symbol Identifier -> Identifier)) 6 | (define (id-prefix sym id) 7 | (let* ((id-sym (syntax-e id)) 8 | (new-id-sym (string->symbol 9 | (string-append (symbol->string sym) 10 | (symbol->string id-sym))))) 11 | (datum->syntax id new-id-sym id id))) 12 | -------------------------------------------------------------------------------- /private/rename.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/splicing) 5 | (require (for-syntax syntax/parse racket/base racket/syntax)) 6 | (provide local-rename) 7 | 8 | (begin-for-syntax 9 | (define-splicing-syntax-class escape 10 | (pattern (~seq) #:attr esc (generate-temporary 'escaper)) 11 | (pattern (~seq #:escaper esc:id)))) 12 | 13 | (define-syntax (local-rename stx) 14 | (syntax-parse stx 15 | ((_ ((orig-binding:id new-binding:id) ...) escaper:escape body:expr ...) 16 | (with-syntax (((saved-orig-binding ...) (generate-temporaries #'(orig-binding ...))) 17 | ((orig-binding2 ...) (generate-temporaries #'(orig-binding ...))) 18 | ((saved-orig-binding2 ...) (generate-temporaries #'(orig-binding ...)))) 19 | #'(splicing-let-syntax 20 | ((saved-orig-binding (make-rename-transformer #'orig-binding)) ... 21 | (saved-escaper (make-rename-transformer #'escaper.esc)) 22 | (orig-binding (make-rename-transformer #'new-binding)) ...) 23 | (splicing-let-syntax ((escaper.esc 24 | (lambda (stx) 25 | (syntax-case stx () 26 | ((head new-body) 27 | (with-syntax ((escaper2 (syntax-local-introduce #'escaper.esc)) 28 | (saved-escaper2 (syntax-local-introduce #'saved-escaper)) 29 | (orig-binding2 (syntax-local-introduce #'orig-binding)) ... 30 | (saved-orig-binding2 (syntax-local-introduce #'saved-orig-binding)) ...) 31 | #'(splicing-let-syntax ((orig-binding2 (make-rename-transformer #'saved-orig-binding2)) ... 32 | (escaper2 (make-rename-transformer #'saved-escaper2))) 33 | new-body))))))) 34 | body ...)))))) 35 | 36 | 37 | -------------------------------------------------------------------------------- /private/safe/structs.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../ffi/ctypes.rkt") 3 | (provide (rename-out 4 | (safe:llvm-value-ref? llvm-value-ref?) 5 | (safe:llvm-type-ref? llvm-type-ref?) 6 | (safe:llvm-module-ref? llvm-module-ref?) 7 | (safe:llvm-context-ref? llvm-context-ref?) 8 | (safe:llvm-basic-block-ref? llvm-basic-block-ref?) 9 | (safe:llvm-builder-ref? llvm-builder-ref?))) 10 | -------------------------------------------------------------------------------- /private/short.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "rename.rkt") 4 | (require "simple/all.rkt") 5 | (require "simple/parameters.rkt") 6 | (require (for-syntax racket/base syntax/parse)) 7 | (require (for-meta 2 racket/base)) 8 | (require racket/list) 9 | 10 | 11 | (provide ll) 12 | 13 | 14 | (define-syntax (current-integer-type-macro stx) 15 | (syntax-case stx () 16 | ((_ args ...) #'((current-integer-type) args ...)) 17 | (_ #'(current-integer-type)))) 18 | 19 | (define-syntax (boolean-type-macro stx) 20 | (syntax-case stx () 21 | ((_ args ...) #'((llvm-int1-type) args ...)) 22 | (_ #'(llvm-int1-type)))) 23 | 24 | (define-syntax (void-type-macro stx) 25 | (syntax-case stx () 26 | ((_ args ...) #'((llvm-void-type) args ...)) 27 | (_ #'(llvm-void-type)))) 28 | 29 | (define-syntax (i8-type-macro stx) 30 | (syntax-case stx () 31 | ((_ args ...) #'((llvm-int8-type) args ...)) 32 | (_ #'(llvm-int8-type)))) 33 | 34 | 35 | 36 | 37 | (define-syntax (current-float-type-macro stx) 38 | (syntax-case stx () 39 | ((_ args ...) #'((current-float-type) args ...)) 40 | (_ #'(current-float-type)))) 41 | 42 | (define (reversed-llvm-function-type #:varargs (varargs #f) arg . args) 43 | (let-values (((arg args) 44 | (let ((rev (reverse (cons arg args)))) 45 | (values (first rev) (reverse (rest rev)))))) 46 | (llvm-function-type* arg #:varargs varargs args))) 47 | 48 | 49 | 50 | (begin-for-syntax 51 | (define-splicing-syntax-class possible-context 52 | (pattern (~seq) #:attr ctx #f) 53 | (pattern (~seq #:context ctx:id)))) 54 | 55 | 56 | (define-syntax (ll stx) 57 | (syntax-parse stx 58 | ((ll c:possible-context body ...) 59 | (define ctx (or (attribute c.ctx) #'ll)) 60 | (define-syntax (local-introduce stx) 61 | (syntax-case stx () 62 | ((_ ctx (args ...) body) 63 | #'(with-syntax ((args (datum->syntax ctx (syntax-e #'args))) ...) body)))) 64 | (local-introduce ctx 65 | (-> > >= < <= = /= return store load alloca + - * / 66 | for when gep gep0 >> << >>> zext sext call 67 | or and xor sqrt loop set ger ger0 68 | bool i8 int float vec arr ptr void unsyntax) 69 | #'(local-rename 70 | ((-> reversed-llvm-function-type) 71 | (int current-integer-type-macro) 72 | (bool boolean-type-macro) 73 | (i8 i8-type-macro) 74 | (vec llvm-vector-type) 75 | (alloca llvm-alloca) 76 | (store llvm-store) 77 | (load llvm-load) 78 | (return llvm-ret) 79 | (for llvm-for) 80 | (loop llvm-loop) 81 | (when llvm-when) 82 | (gep llvm-gep) 83 | (gep0 llvm-gep0) 84 | (ger llvm:ger) 85 | (ger0 llvm:ger0) 86 | (set llvm:set) 87 | (call llvm-call) 88 | (sqrt llvm:sqrt) 89 | (zext llvm-zext) 90 | (sext llvm-sext) 91 | (<< llvm-shl) 92 | (>> llvm-ashr) 93 | (>>> llvm-lshr) 94 | (< llvm-<) 95 | (<= llvm-<=) 96 | (> llvm->) 97 | (>= llvm->=) 98 | (/= llvm-/=) 99 | (= llvm-=) 100 | (+ llvm-+) 101 | (- llvm--) 102 | (* llvm-*) 103 | (/ llvm-/) 104 | (or llvm-or) 105 | (and llvm-and) 106 | (xor llvm-xor) 107 | (arr llvm-array-type) 108 | (ptr llvm-pointer-type) 109 | (void void-type-macro) 110 | (float current-float-type-macro)) 111 | #:escaper unsyntax 112 | (begin 113 | body ...)))))) 114 | -------------------------------------------------------------------------------- /private/simple/aggregate.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/contract 5 | unstable/contract 6 | racket/list 7 | "parameters.rkt" 8 | "types.rkt" 9 | "indexed-types.rkt" 10 | "values.rkt" 11 | "util.rkt" 12 | "convertible.rkt" 13 | "predicates.rkt" 14 | "../ffi/safe.rkt") 15 | 16 | (provide 17 | (contract-out 18 | ;Predicates 19 | (llvm:array? predicate/c) 20 | (llvm:struct? predicate/c) 21 | (llvm:vector? predicate/c) 22 | (llvm-extract-element llvm-extract-element/c) 23 | (llvm-insert-element llvm-insert-element/c) 24 | (llvm-extract-value llvm-extract-value/c) 25 | (llvm-insert-value llvm-insert-value/c) 26 | (llvm-vector llvm-vector/c) 27 | (llvm-vector* llvm-vector*/c) 28 | (llvm-constant-array llvm-constant-array/c) 29 | (llvm-constant-array* llvm-constant-array*/c) 30 | (llvm-struct 31 | (->* () (#:context llvm:context? 32 | #:packed boolean?) 33 | #:rest (listof llvm-value/c) llvm:value?)) 34 | (llvm-named-struct 35 | (->* (llvm:named-struct-type?) 36 | #:rest (listof llvm-value/c) llvm:value?)))) ;TODO Make contract tighter 37 | 38 | 39 | 40 | 41 | ;Predicates 42 | (define (llvm:array? v) 43 | (and (llvm:value/c v) 44 | (llvm:array-type? 45 | (value->llvm-type v)))) 46 | 47 | (define (llvm:struct? v) 48 | (and (llvm:value/c v) 49 | (llvm:struct-type? 50 | (value->llvm-type v)))) 51 | 52 | (define (llvm:vector? v) 53 | (and (llvm:value/c v) 54 | (llvm:vector-type? 55 | (value->llvm-type v)))) 56 | 57 | 58 | ;Contracts 59 | (define llvm-extract-element/c 60 | (->* (llvm:vector? 61 | llvm-integer32/c) 62 | (#:builder llvm:builder? 63 | #:name string?) 64 | llvm:value?)) 65 | 66 | (define llvm-insert-element/c 67 | (->i ((vector llvm:vector?) 68 | (arg llvm-value/c) 69 | (index llvm-integer32/c)) 70 | (#:builder (builder llvm:builder?) 71 | #:name (name string?)) 72 | #:pre/name (vector arg) 73 | "Element and vector types don't match" 74 | (equal? (llvm-get-element-type (value->llvm-type vector)) 75 | (value->llvm-type arg)) 76 | (_ llvm:value?))) 77 | 78 | 79 | (define llvm-extract-value/c 80 | (->i ((aggregate (or/c llvm:array? llvm:struct?)) 81 | (index exact-nonnegative-integer?)) 82 | (#:builder (builder llvm:builder?) 83 | #:name (name string?)) 84 | #:pre/name (aggregate index) 85 | "Invalid array index" 86 | (or (not (llvm:array? aggregate)) 87 | (let ((size (llvm-get-array-type-length (value->llvm-type aggregate)))) 88 | (or (zero? size) 89 | (< index size)))) 90 | #:pre/name (aggregate index) 91 | "Invalid struct index" 92 | (or (not (llvm:struct? aggregate)) 93 | (llvm-is-valid-type-index (value->llvm-type aggregate) index)) 94 | (_ llvm:value?))) 95 | 96 | (define llvm-insert-value/c 97 | (->i ((aggregate (or/c llvm:array? llvm:struct?)) 98 | (arg llvm-value/c) 99 | (index exact-nonnegative-integer?)) 100 | (#:builder (builder llvm:builder?) 101 | #:name (name string?)) 102 | #:pre/name (aggregate index) 103 | "Invalid array index" 104 | (or (not (llvm:array? aggregate)) 105 | (let ((size (llvm-get-array-type-length (value->llvm-type aggregate)))) 106 | (or (zero? size) 107 | (< index size)))) 108 | #:pre/name (aggregate index) 109 | "Invalid struct index" 110 | (or (not (llvm:struct? aggregate)) 111 | (llvm-is-valid-type-index (value->llvm-type aggregate) index)) 112 | #:pre/name (aggregate index arg) 113 | "Element and aggregate types don't match" 114 | (equal? (llvm-get-type-at-index (value->llvm-type aggregate) index) 115 | (value->llvm-type arg)) 116 | (_ llvm:value?))) 117 | 118 | 119 | (define llvm-vector/c 120 | (->i () 121 | (#:builder (builder llvm:builder?)) 122 | #:rest (args (non-empty-listof llvm-value/c)) 123 | #:pre/name (args) 124 | "Element types don't match" 125 | (let ((t (value->llvm-type (first args)))) 126 | (andmap (lambda (e) (equal? t (value->llvm-type e))) 127 | (rest args))) 128 | (_ llvm:value?))) 129 | 130 | 131 | (define llvm-vector*/c 132 | (->i () 133 | (#:builder (builder llvm:builder?)) 134 | #:rest (args (non-empty-list*/c llvm-value/c)) 135 | #:pre/name (args) 136 | "Element types don't match" 137 | (let ((args (apply list* args))) 138 | (let ((t (value->llvm-type (first args)))) 139 | (andmap (lambda (e) (equal? t (value->llvm-type e))) 140 | (rest args)))) 141 | (_ llvm:value?))) 142 | 143 | 144 | (define llvm-constant-array/c 145 | (->i () 146 | () 147 | #:rest (args (non-empty-listof llvm-constant-value/c)) 148 | #:pre/name (args) 149 | "Element types don't match" 150 | (let ((elem-type (value->llvm-type (first args)))) 151 | (for ((arg (rest args))) 152 | (equal? elem-type (value->llvm-type arg)))) 153 | (_ llvm:value?))) 154 | 155 | 156 | (define llvm-constant-array*/c 157 | (->i () 158 | () 159 | #:rest (args (non-empty-list*/c llvm-constant-value/c)) 160 | #:pre/name (args) 161 | "Element types don't match" 162 | (let ((args (apply list* args))) 163 | (let ((elem-type (value->llvm-type (first args)))) 164 | (for ((arg (rest args))) 165 | (equal? elem-type (value->llvm-type arg))))) 166 | (_ llvm:value?))) 167 | 168 | 169 | (define (llvm-extract-element v index #:builder (builder (current-builder)) #:name (name "")) 170 | (LLVMBuildExtractElement builder (value->llvm v) (value->llvm index) name)) 171 | 172 | (define (llvm-insert-element v arg index #:builder (builder (current-builder)) #:name (name "")) 173 | (LLVMBuildInsertElement builder (value->llvm v) (value->llvm arg) (value->llvm index) name)) 174 | 175 | 176 | (define (llvm-extract-value v index #:builder (builder (current-builder)) #:name (name "")) 177 | (LLVMBuildExtractValue builder (value->llvm v) index name)) 178 | 179 | (define (llvm-insert-value v arg index #:builder (builder (current-builder)) #:name (name "")) 180 | (LLVMBuildInsertValue builder (value->llvm v) (value->llvm arg) index name)) 181 | 182 | 183 | 184 | (define (llvm-vector #:builder (builder (current-builder)) . args) 185 | (for/fold ((acc (llvm-null (llvm-vector-type (value->llvm-type (first args)) (length args))))) 186 | ((arg args) (i (in-naturals))) 187 | (llvm-insert-element acc arg i #:builder builder))) 188 | 189 | 190 | (define (llvm-vector* #:builder (builder (current-builder)) . args) 191 | (apply llvm-vector #:builder builder (apply list* args))) 192 | 193 | 194 | 195 | (define (llvm-constant-array . args) 196 | (LLVMConstArray (value->llvm-type (first args)) 197 | (map value->llvm args))) 198 | (define (llvm-constant-array* . args) 199 | (apply llvm-constant-array (apply list* args))) 200 | 201 | 202 | 203 | 204 | 205 | 206 | (define (llvm-struct #:context (context (current-context)) #:packed (packed #f) . args) 207 | (LLVMConstStructInContext context (map value->llvm args) packed)) 208 | 209 | (define (llvm-named-struct ty . args) 210 | (LLVMConstNamedStruct ty (map value->llvm args))) 211 | 212 | 213 | 214 | 215 | -------------------------------------------------------------------------------- /private/simple/all.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "../ffi/safe.rkt" 5 | "util.rkt" 6 | "aggregate.rkt" 7 | "binop.rkt" 8 | "builder.rkt" 9 | "cast.rkt" 10 | "comparison.rkt" 11 | "convertible.rkt" 12 | "extra.rkt" 13 | "functions.rkt" 14 | "generic.rkt" 15 | "globals.rkt" 16 | "intrinsics.rkt" 17 | "memory.rkt" 18 | "misc-instructions.rkt" 19 | "modules.rkt" 20 | "parameters.rkt" 21 | "predicates.rkt" 22 | "references.rkt" 23 | "runtime.rkt" 24 | "types.rkt" 25 | "indexed-types.rkt" 26 | "values.rkt") 27 | 28 | 29 | (provide (all-from-out 30 | "aggregate.rkt" 31 | "binop.rkt" 32 | "builder.rkt" 33 | "comparison.rkt" 34 | "cast.rkt" 35 | "extra.rkt" 36 | "functions.rkt" 37 | "generic.rkt" 38 | "globals.rkt" 39 | "intrinsics.rkt" 40 | "memory.rkt" 41 | "misc-instructions.rkt" 42 | "modules.rkt" 43 | "references.rkt" 44 | "runtime.rkt" 45 | "types.rkt" 46 | "indexed-types.rkt" 47 | "values.rkt")) 48 | 49 | 50 | (provide 51 | llvm-value/c 52 | llvm-int 53 | value->llvm-type 54 | enter-module/32 55 | define-basic-block 56 | llvm-get-type-kind 57 | llvm-get-return-type 58 | llvm-gep-type 59 | llvm-get-element-type 60 | llvm-get-undef) 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | -------------------------------------------------------------------------------- /private/simple/binop.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/contract/base 5 | "../ffi/safe.rkt" 6 | "convertible.rkt" 7 | "predicates.rkt" 8 | "parameters.rkt") 9 | 10 | (provide 11 | (contract-out 12 | (llvm-+ llvm-binop/c) 13 | (llvm-* llvm-binop/c) 14 | (llvm-- llvm-binop/c) 15 | (llvm-/ llvm-binop/c) 16 | 17 | (llvm-i+ llvm-int-binop/c) 18 | (llvm-i* llvm-int-binop/c) 19 | (llvm-i- llvm-int-binop/c) 20 | (llvm-i/ llvm-int-binop/c) 21 | (llvm-i% llvm-int-binop/c) 22 | (llvm-and llvm-int-binop/c) 23 | (llvm-or llvm-int-binop/c) 24 | (llvm-xor llvm-int-binop/c) 25 | (llvm-lshr llvm-int-binop/c) 26 | (llvm-ashr llvm-int-binop/c) 27 | (llvm-shl llvm-int-binop/c) 28 | 29 | (llvm-fl+ llvm-float-binop/c) 30 | (llvm-fl- llvm-float-binop/c) 31 | (llvm-fl* llvm-float-binop/c) 32 | (llvm-fl/ llvm-float-binop/c))) 33 | 34 | 35 | (define llvm-float-binop/c 36 | (->i ((left llvm-float/c) 37 | (right llvm-float/c)) 38 | (#:builder (builder llvm:builder?) 39 | #:name (name string?)) 40 | #:pre/name (left right) 41 | "Types do not match" 42 | (equal? (value->llvm-type left) (value->llvm-type right)) 43 | (_ llvm:value?))) 44 | 45 | (define llvm-int-binop/c 46 | (->i ((left llvm-integer/c) 47 | (right llvm-integer/c)) 48 | (#:builder (builder llvm:builder?) 49 | #:name (name string?)) 50 | #:pre/name (left right) 51 | "Types do not match" 52 | (equal? (value->llvm-type left) (value->llvm-type right)) 53 | (_ llvm:value?))) 54 | 55 | (define llvm-binop/c 56 | (->i ((left (or/c llvm-integer/c llvm-float/c)) 57 | (right (or/c llvm-integer/c llvm-float/c))) 58 | (#:builder (builder llvm:builder?) 59 | #:name (name string?)) 60 | #:pre/name (left right) 61 | "Types do not match" 62 | (equal? (value->llvm-type left) (value->llvm-type right)) 63 | (_ llvm:value?))) 64 | 65 | 66 | 67 | ;Provided functions 68 | (define (llvm-i+ lhv rhv #:builder (builder (current-builder)) #:name (name "")) 69 | (LLVMBuildAdd builder (integer->llvm lhv) (integer->llvm rhv) name)) 70 | 71 | (define (llvm-i* lhv rhv #:builder (builder (current-builder)) #:name (name "")) 72 | (LLVMBuildMul builder (integer->llvm lhv) (integer->llvm rhv) name)) 73 | 74 | (define (llvm-i- lhv rhv #:builder (builder (current-builder)) #:name (name "")) 75 | (LLVMBuildSub builder (integer->llvm lhv) (integer->llvm rhv) name)) 76 | 77 | (define (llvm-i/ lhv rhv #:builder (builder (current-builder)) #:name (name "")) 78 | (LLVMBuildSDiv builder (integer->llvm lhv) (integer->llvm rhv) name)) 79 | 80 | (define (llvm-i% lhv rhv #:builder (builder (current-builder)) #:name (name "")) 81 | (LLVMBuildSRem builder (integer->llvm lhv) (integer->llvm rhv) name)) 82 | 83 | 84 | (define (llvm-and lhv rhv #:builder (builder (current-builder)) #:name (name "")) 85 | (LLVMBuildAnd builder (integer->llvm lhv) (integer->llvm rhv) name)) 86 | 87 | (define (llvm-or lhv rhv #:builder (builder (current-builder)) #:name (name "")) 88 | (LLVMBuildOr builder (integer->llvm lhv) (integer->llvm rhv) name)) 89 | 90 | (define (llvm-xor lhv rhv #:builder (builder (current-builder)) #:name (name "")) 91 | (LLVMBuildXor builder (integer->llvm lhv) (integer->llvm rhv) name)) 92 | 93 | 94 | (define (llvm-ashr lhv rhv #:builder (builder (current-builder)) #:name (name "")) 95 | (LLVMBuildAShr builder (integer->llvm lhv) (integer->llvm rhv) name)) 96 | 97 | (define (llvm-lshr lhv rhv #:builder (builder (current-builder)) #:name (name "")) 98 | (LLVMBuildLShr builder (integer->llvm lhv) (integer->llvm rhv) name)) 99 | 100 | 101 | 102 | (define (llvm-shl lhv rhv #:builder (builder (current-builder)) #:name (name "")) 103 | (LLVMBuildShl builder (integer->llvm lhv) (integer->llvm rhv) name)) 104 | 105 | 106 | (define (llvm-fl+ lhv rhv #:builder (builder (current-builder)) #:name (name "")) 107 | (LLVMBuildFAdd builder (float->llvm lhv) (float->llvm rhv) name)) 108 | 109 | (define (llvm-fl* lhv rhv #:builder (builder (current-builder)) #:name (name "")) 110 | (LLVMBuildFMul builder (float->llvm lhv) (float->llvm rhv) name)) 111 | 112 | 113 | (define (llvm-fl- lhv rhv #:builder (builder (current-builder)) #:name (name "")) 114 | (LLVMBuildFSub builder (float->llvm lhv) (float->llvm rhv) name)) 115 | 116 | (define (llvm-fl/ lhv rhv #:builder (builder (current-builder)) #:name (name "")) 117 | (LLVMBuildFDiv builder (float->llvm lhv) (float->llvm rhv) name)) 118 | 119 | (define ((llvm-binop-chooser int float) lhv rhv #:builder (builder (current-builder)) #:name (name "")) 120 | ((if (llvm-integer/c lhv) int float) lhv rhv #:builder builder #:name name)) 121 | 122 | (define llvm-+ (llvm-binop-chooser llvm-i+ llvm-fl+)) 123 | (define llvm-- (llvm-binop-chooser llvm-i- llvm-fl-)) 124 | (define llvm-* (llvm-binop-chooser llvm-i* llvm-fl*)) 125 | (define llvm-/ (llvm-binop-chooser llvm-i/ llvm-fl/)) 126 | 127 | 128 | -------------------------------------------------------------------------------- /private/simple/builder.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/contract 5 | "../ffi/safe.rkt" 6 | "parameters.rkt" 7 | "predicates.rkt" 8 | "functions.rkt") 9 | 10 | 11 | (provide 12 | (contract-out 13 | (llvm-create-builder 14 | (->* () (#:context llvm:context?) llvm:builder?)) 15 | 16 | 17 | (llvm-set-position 18 | (->* (llvm:basic-block?) (#:builder llvm:builder?) void?)) 19 | (llvm-get-insert-block 20 | (->* () (#:builder llvm:builder?) llvm:basic-block?)) 21 | (llvm-add-block 22 | (->* () 23 | (#:context llvm:context? 24 | #:builder llvm:builder? 25 | #:name string?) 26 | llvm:basic-block?)) 27 | 28 | (llvm-add-block-to-function 29 | (->* (llvm:function-pointer?) 30 | (#:context llvm:context? 31 | #:name string?) 32 | llvm:basic-block?)) 33 | (builder->function (-> llvm:builder? llvm:function-pointer?)) 34 | (builder->module (-> llvm:builder? llvm:module?)))) 35 | 36 | 37 | (define (llvm-create-builder #:context (context (current-context))) 38 | (LLVMCreateBuilderInContext context)) 39 | 40 | (define (llvm-add-block-to-function function 41 | #:context (context (current-context)) 42 | #:name (name "")) 43 | (LLVMAppendBasicBlockInContext context function name)) 44 | 45 | 46 | (define (builder->function builder) 47 | (LLVMGetBasicBlockParent (LLVMGetInsertBlock builder))) 48 | 49 | (define (builder->module builder) 50 | (LLVMGetGlobalParent (builder->function builder))) 51 | 52 | 53 | (define (llvm-get-insert-block #:builder (builder (current-builder))) 54 | (LLVMGetInsertBlock builder)) 55 | 56 | 57 | (define (llvm-set-position block #:builder (builder (current-builder))) 58 | (LLVMPositionBuilderAtEnd builder block)) 59 | 60 | (define (llvm-add-block 61 | #:context (context (current-context)) 62 | #:builder (builder (current-builder)) 63 | #:name (name "")) 64 | (LLVMAppendBasicBlockInContext context (builder->function builder) name)) 65 | 66 | 67 | -------------------------------------------------------------------------------- /private/simple/cast.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/contract 5 | "../ffi/safe.rkt" 6 | "convertible.rkt" 7 | "predicates.rkt" 8 | "parameters.rkt") 9 | 10 | (provide 11 | (contract-out 12 | (llvm-bit-cast (->* (llvm:value? llvm:type?) (#:builder llvm:builder? #:name string?) llvm:value?)) 13 | (llvm-int-to-ptr (->* (llvm-integer/c llvm:type?) (#:builder llvm:builder? #:name string?) llvm:value?)) 14 | (llvm-ptr-to-int (->* (llvm:value?) (llvm:type? #:builder llvm:builder? #:name string?) llvm:value?)) 15 | (llvm-sext (->* (llvm-integer/c llvm:type?) (#:builder llvm:builder? #:name string?) llvm:value?)) 16 | (llvm-zext (->* (llvm-integer/c llvm:type?) (#:builder llvm:builder? #:name string?) llvm:value?)) 17 | (llvm-trunc (->* (llvm-integer/c llvm:type?) (#:builder llvm:builder? #:name string?) llvm:value?)))) 18 | 19 | 20 | (define (llvm-bit-cast pointer type #:builder (builder (current-builder)) #:name (name "")) 21 | (LLVMBuildBitCast builder pointer type name)) 22 | 23 | (define (llvm-ptr-to-int pointer (type (current-integer-type)) #:builder (builder (current-builder)) #:name (name "")) 24 | (LLVMBuildPtrToInt builder pointer type name)) 25 | 26 | (define (llvm-int-to-ptr int type #:builder (builder (current-builder)) #:name (name "")) 27 | (LLVMBuildIntToPtr builder (value->llvm int) type name)) 28 | 29 | (define (llvm-sext value type #:builder (builder (current-builder)) #:name (name "")) 30 | (LLVMBuildSExt builder (value->llvm value) type name)) 31 | 32 | (define (llvm-zext value type #:builder (builder (current-builder)) #:name (name "")) 33 | (LLVMBuildZExt builder (value->llvm value) type name)) 34 | 35 | 36 | (define (llvm-trunc value type #:builder (builder (current-builder)) #:name (name "")) 37 | (LLVMBuildTrunc builder (value->llvm value) type name)) 38 | -------------------------------------------------------------------------------- /private/simple/comparison.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/contract/base 5 | racket/match 6 | "../ffi/safe.rkt" 7 | "convertible.rkt" 8 | "predicates.rkt" 9 | "parameters.rkt") 10 | 11 | (provide 12 | (contract-out 13 | (llvm-icmp icmp/c) 14 | (llvm-fcmp fcmp/c) 15 | (llvm-i= int-comparison/c) 16 | (llvm-i/= int-comparison/c) 17 | (llvm-i> int-comparison/c) 18 | (llvm-i>= int-comparison/c) 19 | (llvm-i< int-comparison/c) 20 | (llvm-i<= int-comparison/c) 21 | 22 | (llvm-fl= float-comparison/c) 23 | (llvm-fl/= float-comparison/c) 24 | (llvm-fl> float-comparison/c) 25 | (llvm-fl>= float-comparison/c) 26 | (llvm-fl< float-comparison/c) 27 | (llvm-fl<= float-comparison/c) 28 | 29 | (llvm-= comparison/c) 30 | (llvm-/= comparison/c) 31 | (llvm-> comparison/c) 32 | (llvm->= comparison/c) 33 | (llvm-< comparison/c) 34 | (llvm-<= comparison/c))) 35 | 36 | (define llvm-integer-or-pointer/c 37 | (or/c llvm-any-pointer/c llvm-integer/c)) 38 | 39 | (define comparison-symbol/c 40 | (symbols '= '/= '< '> '<= '>=)) 41 | 42 | (define float-comparison-symbol/c 43 | (symbols 'true 'false 'order '= '/= '< '> '<= '>=)) 44 | 45 | 46 | (define icmp/c 47 | (->i ((symbol comparison-symbol/c) 48 | (left llvm-integer/c) 49 | (right llvm-integer/c)) 50 | (#:builder (builder llvm:builder?) 51 | #:signed (signed boolean?) 52 | #:name (name string?)) 53 | #:pre/name (left right) 54 | "Equal types" 55 | (equal? 56 | (value->llvm-type left) 57 | (value->llvm-type left)) 58 | (_ llvm:value?))) 59 | 60 | (define fcmp/c 61 | (->i ((symbol float-comparison-symbol/c) 62 | (left llvm-float/c) 63 | (right llvm-float/c)) 64 | (#:builder (builder llvm:builder?) 65 | #:ordered (ordered boolean?) 66 | #:name (name string?)) 67 | #:pre/name (left right) 68 | "Equal types" 69 | (equal? 70 | (value->llvm-type left) 71 | (value->llvm-type left)) 72 | (_ llvm:value?))) 73 | 74 | 75 | 76 | (define int-comparison/c 77 | (->i ((left llvm-integer-or-pointer/c) 78 | (right llvm-integer-or-pointer/c)) 79 | (#:builder (builder llvm:builder?) 80 | #:signed (signed boolean?) 81 | #:name (name string?)) 82 | #:pre/name (left right) 83 | "Equal types" 84 | (equal? 85 | (value->llvm-type left) 86 | (value->llvm-type left)) 87 | (_ llvm:value?))) 88 | 89 | 90 | (define comparison/c 91 | (->i ((left (or/c llvm-float/c llvm-integer-or-pointer/c)) 92 | (right (or/c llvm-float/c llvm-integer-or-pointer/c))) 93 | (#:builder (builder llvm:builder?) 94 | #:signed (signed boolean?) 95 | #:ordered (ordered boolean?) 96 | #:name (name string?)) 97 | #:pre/name (left right) 98 | "Equal types" 99 | (equal? 100 | (value->llvm-type left) 101 | (value->llvm-type left)) 102 | #:pre/name (left ordered) 103 | "Ordered only used with float types" 104 | (or (unsupplied-arg? ordered) 105 | (llvm-float/c left)) 106 | #:pre/name (left signed) 107 | "Signed only used with integer types" 108 | (or (unsupplied-arg? signed) 109 | (llvm-integer-or-pointer/c left)) 110 | (_ llvm:value?))) 111 | 112 | 113 | 114 | 115 | 116 | (define float-comparison/c 117 | (->i ((left llvm-float/c) 118 | (right llvm-float/c)) 119 | (#:builder (builder llvm:builder?) 120 | #:ordered (ordered boolean?) 121 | #:name (name string?)) 122 | #:pre/name (left right) 123 | "Equal types" 124 | (equal? 125 | (value->llvm-type left) 126 | (value->llvm-type left)) 127 | (_ llvm:value?))) 128 | 129 | 130 | (define (llvm-icmp type lhv rhv #:signed (signed #t) #:builder (builder (current-builder)) #:name (name "")) 131 | (LLVMBuildICmp builder 132 | (symbol->llvm-int-predicate type signed) 133 | (integer->llvm lhv) 134 | (integer->llvm rhv) 135 | name)) 136 | 137 | 138 | (define (llvm-fcmp symbol 139 | lhv rhv 140 | #:ordered (ordered #t) 141 | #:builder (builder (current-builder)) 142 | #:name (name "")) 143 | (LLVMBuildFCmp builder 144 | (symbol->llvm-float-predicate symbol ordered) 145 | (float->llvm lhv) 146 | (float->llvm rhv) 147 | name)) 148 | 149 | 150 | (define ((make-specific-comparison symbol) lhv rhv #:signed (signed #t) #:builder (builder (current-builder)) #:name (name "")) 151 | (llvm-icmp symbol lhv rhv #:signed signed #:builder builder #:name name)) 152 | 153 | (define llvm-i= (make-specific-comparison '=)) 154 | (define llvm-i/= (make-specific-comparison '/=)) 155 | (define llvm-i< (make-specific-comparison '<)) 156 | (define llvm-i> (make-specific-comparison '>)) 157 | (define llvm-i<= (make-specific-comparison '<=)) 158 | (define llvm-i>= (make-specific-comparison '>=)) 159 | 160 | 161 | (define ((make-specific-float-comparison symbol) lhv rhv 162 | #:builder (builder (current-builder)) 163 | #:ordered (ordered #t) 164 | #:name (name "")) 165 | (llvm-fcmp symbol 166 | lhv rhv #:builder builder #:ordered ordered #:name name)) 167 | 168 | (define llvm-fl= (make-specific-float-comparison '=)) 169 | (define llvm-fl> (make-specific-float-comparison '>)) 170 | (define llvm-fl>= (make-specific-float-comparison '>=)) 171 | (define llvm-fl< (make-specific-float-comparison '<)) 172 | (define llvm-fl<= (make-specific-float-comparison '<=)) 173 | (define llvm-fl/= (make-specific-float-comparison '/=)) 174 | 175 | 176 | (define (symbol->llvm-float-predicate sym ordered) 177 | (match* (sym ordered) 178 | (('false _) 'LLVMRealPredicateFalse) 179 | (('true _) 'LLVMRealPredicateFalse) 180 | (('= #t) 'LLVMRealOEQ) 181 | (('= #f) 'LLVMRealUEQ) 182 | (('> #t) 'LLVMRealOGT) 183 | (('> #f) 'LLVMRealUGT) 184 | (('>= #t) 'LLVMRealOGE) 185 | (('>= #f) 'LLVMRealUGE) 186 | (('< #t) 'LLVMRealOLT) 187 | (('< #f) 'LLVMRealULT) 188 | (('<= #t) 'LLVMRealOLE) 189 | (('<= #f) 'LLVMRealULE) 190 | (('/= #t) 'LLVMRealONE) 191 | (('/= #f) 'LLVMRealUNE) 192 | (('order #t) 'LLVMRealORD) 193 | (('order #f) 'LLVMRealUNO))) 194 | 195 | 196 | 197 | (define (symbol->llvm-int-predicate sym signed) 198 | (case sym 199 | ((=) 'LLVMIntEQ) 200 | ((/=) 'LLVMIntNE) 201 | ((>) (if signed 'LLVMIntSGT 'LLVMIntUGT)) 202 | ((>=) (if signed 'LLVMIntSGE 'LLVMIntUGE)) 203 | ((<) (if signed 'LLVMIntSLT 'LLVMIntULT)) 204 | ((<=) (if signed 'LLVMIntSLE 'LLVMIntULE)) 205 | (else (error 'symbol->llvm-int-predicate "Expected comparison symbol, got ~a" sym)))) 206 | 207 | (define ((llvm-comparison-chooser int float) 208 | lhv rhv 209 | #:builder (builder (current-builder)) 210 | #:signed (signed #t) 211 | #:ordered (ordered #t) 212 | #:name (name "")) 213 | (if (llvm-integer-or-pointer/c lhv) 214 | (int lhv rhv #:builder builder #:signed signed #:name name) 215 | (float lhv rhv #:builder builder #:ordered ordered #:name name))) 216 | 217 | (define llvm-= (llvm-comparison-chooser llvm-i= llvm-fl=)) 218 | (define llvm-/= (llvm-comparison-chooser llvm-i/= llvm-fl/=)) 219 | (define llvm-> (llvm-comparison-chooser llvm-i> llvm-fl>)) 220 | (define llvm->= (llvm-comparison-chooser llvm-i>= llvm-fl>=)) 221 | (define llvm-< (llvm-comparison-chooser llvm-i< llvm-fl<)) 222 | (define llvm-<= (llvm-comparison-chooser llvm-i<= llvm-fl<=)) 223 | 224 | 225 | -------------------------------------------------------------------------------- /private/simple/convertible.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/contract/base 5 | racket/contract/combinator 6 | unstable/contract 7 | "../ffi/safe.rkt" 8 | "types.rkt" 9 | "values.rkt" 10 | "predicates.rkt" 11 | "parameters.rkt") 12 | 13 | (provide 14 | (contract-out 15 | ;TODO get rid of duplicate bindings 16 | (llvm-value/c contract?) 17 | (llvm:value/c contract?) 18 | (llvm-constant-value/c contract?) 19 | (llvm-any-pointer/c contract?) 20 | (llvm-current-integer/c contract?) 21 | (llvm-integer/c contract?) 22 | (llvm-integer32/c contract?) 23 | (llvm-float/c contract?) 24 | (llvm-boolean/c contract?) 25 | (llvm-int 26 | (->* (integer?) 27 | (llvm:integer-type? 28 | #:signed? boolean?) 29 | llvm:value?)) 30 | (prop:llvm-value 31 | (struct-type-property/c 32 | (->i ((extended llvm-extended-value?)) 33 | (values (value (type) (llvm:type/c type)) 34 | (type llvm:type?))))) 35 | (llvm:type/c (-> llvm:type? predicate/c)))) 36 | 37 | 38 | ;TODO enhance contract 39 | (provide 40 | integer->llvm 41 | float->llvm 42 | boolean->llvm 43 | string->llvm 44 | value->llvm 45 | value->llvm-type) 46 | 47 | 48 | 49 | (define-values (prop:llvm-value llvm-extended-value? llvm-extended-value-acc) 50 | (make-struct-type-property 'llvm-value)) 51 | 52 | (define (llvm-extended-value-value v) 53 | (let-values (((value type) ((llvm-extended-value-acc v) v))) 54 | value)) 55 | (define (llvm-extended-value-type v) 56 | (let-values (((value type) ((llvm-extended-value-acc v) v))) 57 | type)) 58 | 59 | 60 | ;Constructors 61 | 62 | ;Integer Creation 63 | (define (llvm-int n (type (current-integer-type)) #:signed? (signed #t)) 64 | (LLVMConstInt type n signed)) 65 | 66 | 67 | ;Coercions 68 | (define (integer->llvm n) 69 | (value->llvm n)) 70 | 71 | 72 | (define (float->llvm n) 73 | (value->llvm n)) 74 | 75 | 76 | (define (boolean->llvm n) 77 | (value->llvm n)) 78 | 79 | (define (string->llvm v #:null-terminate (null-terminate #f)) 80 | (cond 81 | ((string? v) (LLVMConstStringInContext (current-context) v (not null-terminate))) 82 | ((llvm-extended-value? v) (string->llvm (llvm-extended-value-value v) #:null-terminate null-terminate)) 83 | ((llvm:value? v) v) 84 | (else (error 'string->llvm "Unknown input value ~a" v)))) 85 | 86 | 87 | (define (value->llvm v) 88 | (cond 89 | ((llvm-extended-value? v) (value->llvm (llvm-extended-value-value v))) 90 | ((boolean? v) (LLVMConstInt (current-boolean-type) (if v 1 0) #t)) 91 | ((exact-integer? v) (LLVMConstInt (current-integer-type) v #t)) 92 | ((real? v) (LLVMConstReal (current-float-type) v)) 93 | ((string? v) (LLVMConstStringInContext (current-context) v #t)) 94 | ((llvm:value? v) v) 95 | (else (error 'base-value->llvm "Unknown input value ~a" v)))) 96 | 97 | ;Type Level 98 | (define (value->llvm-type v) 99 | (cond 100 | ((llvm-extended-value? v) (llvm-extended-value-type v)) 101 | ((exact-integer? v) (current-integer-type)) 102 | ((real? v) (current-float-type)) 103 | ((boolean? v) (current-boolean-type)) 104 | ((llvm:value? v) (LLVMTypeOf v)) 105 | (else (error 'value->llvm-type "Unknown input value ~a" v)))) 106 | 107 | 108 | ;Contracts 109 | 110 | 111 | (define llvm-current-integer/c 112 | (flat-named-contract 'llvm-current-integer/c 113 | (lambda (n) (or (exact-integer? n) 114 | (and (llvm:value/c n) 115 | (equal? 116 | (current-integer-type) 117 | (value->llvm-type n))))))) 118 | 119 | 120 | 121 | 122 | (define llvm-integer/c 123 | (flat-named-contract 'llvm-integer/c 124 | (lambda (n) (or (exact-integer? n) 125 | (and (llvm:value/c n) 126 | (llvm:integer-type? 127 | (value->llvm-type n))))))) 128 | 129 | (define llvm-integer32/c 130 | (flat-named-contract 'llvm-integer32/c 131 | (lambda (n) 132 | (define (check-type ty) 133 | (equal? 32 134 | (llvm-get-int-type-width ty))) 135 | (cond 136 | ((exact-integer? n) 137 | (check-type (current-integer-type))) 138 | ((llvm:value/c n) 139 | (let ((ty (value->llvm-type n))) 140 | (and (llvm:integer-type? ty) 141 | (check-type ty)))) 142 | (else #f))))) 143 | 144 | 145 | 146 | (define llvm-float/c 147 | (flat-named-contract 'llvm-float/c 148 | (lambda (n) (or (real? n) 149 | (and (llvm:value/c n) 150 | (llvm:float-type? 151 | (value->llvm-type n))))))) 152 | 153 | (define llvm-any-pointer/c 154 | (flat-named-contract 'llvm-any-pointer/c 155 | (lambda (v) 156 | (and (llvm:value/c v) 157 | (let ((t (value->llvm-type v))) 158 | (and (eq? (llvm-get-type-kind t) 159 | 'LLVMPointerTypeKind))))))) 160 | 161 | 162 | 163 | 164 | 165 | 166 | (define llvm-boolean/c 167 | (flat-named-contract 'llvm-boolean/c 168 | (lambda (n) (or (boolean? n) ((llvm:type/c (current-boolean-type)) n))))) 169 | 170 | 171 | (define llvm-value/c 172 | (flat-named-contract 'llvm-value 173 | (lambda (v) (or (string? v) 174 | (boolean? v) 175 | (exact-integer? v) 176 | (real? v) 177 | (llvm-extended-value? v) 178 | (llvm:value? v))))) 179 | 180 | (define llvm:value/c llvm-value/c) 181 | 182 | (define llvm-constant-extended-value/c 183 | (make-chaperone-contract 184 | #:name 'llvm-constant-exteneded-value/c 185 | #:first-order llvm-extended-value? 186 | #:projection 187 | (lambda (blame) 188 | (lambda (v) 189 | (chaperone-struct v 190 | llvm-extended-value-acc 191 | (lambda (v f) 192 | (define proj (contract-projection (-> llvm-extended-value? (values llvm-constant-value/c any/c)))) 193 | ((proj blame) f))))))) 194 | 195 | (define llvm-constant-value/c 196 | (or/c 197 | (flat-named-contract 'llvm-constant-base-value 198 | (lambda (v) (or (string? v) 199 | (boolean? v) 200 | (exact-integer? v) 201 | (real? v) 202 | (and (llvm:value? v) 203 | (llvm:constant? v))))) 204 | llvm-constant-extended-value/c)) 205 | 206 | (define (llvm:type/c type) 207 | (flat-named-contract `(type/c ,type) 208 | (lambda (value) 209 | (and (llvm:value/c value) 210 | (equal? (value->llvm-type value) type))))) 211 | 212 | 213 | -------------------------------------------------------------------------------- /private/simple/extra.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/contract 5 | "aggregate.rkt" 6 | "parameters.rkt" 7 | "memory.rkt" 8 | "globals.rkt" 9 | "convertible.rkt" 10 | "modules.rkt" 11 | "memory.rkt" 12 | "predicates.rkt" 13 | "references.rkt" 14 | "types.rkt" 15 | "builder.rkt" 16 | "functions.rkt" 17 | "misc-instructions.rkt" 18 | "../ffi/safe.rkt" 19 | (only-in "../ffi/ctypes.rkt" set-safe:llvm-builder-ref-module!) 20 | (for-syntax racket/base syntax/parse racket/syntax racket/list racket/function)) 21 | 22 | 23 | (provide llvm-if llvm-for llvm-when llvm-unless llvm-loop 24 | llvm-declare-function 25 | llvm-define-global 26 | llvm-define-function llvm-define-module 27 | llvm-define-struct 28 | llvm-implement-function 29 | enter-module/32 define-basic-block 30 | llvm:box) 31 | 32 | 33 | (define-syntax (enter-module/32 stx) 34 | (syntax-case stx () 35 | ((_ context-expr module-expr body bodies ...) 36 | #'(let ((context context-expr) 37 | (module module-expr)) 38 | (parameterize ((current-module module) 39 | (current-context context) 40 | (current-builder (llvm-create-builder #:context context)) 41 | (current-integer-type (llvm-int32-type #:context context))) 42 | body bodies ...))))) 43 | 44 | 45 | 46 | (define-syntax (define-basic-block stx) 47 | (syntax-case stx () 48 | ((_ id ...) 49 | (with-syntax ((((id name) ...) 50 | (for/list ((id (syntax->list #'(id ...)))) 51 | (list id (symbol->string (syntax-e id)))))) 52 | #`(begin 53 | (define id (llvm-add-block #:name name)) ...))))) 54 | 55 | (define (llvm-get-terminator (block (llvm-get-insert-block))) 56 | (LLVMGetBasicBlockTerminator block)) 57 | 58 | 59 | (define-syntax (llvm-maybe stx) 60 | (syntax-parse stx 61 | ((_ expr:expr ...) 62 | #'(unless (llvm-get-terminator) 63 | expr ...)))) 64 | 65 | 66 | (define-syntaxes (llvm-when llvm-unless) 67 | (let () 68 | (define (maker which) 69 | (lambda (stx) 70 | (syntax-parse stx 71 | ((_ cond-expr:expr then-expr:expr ...) 72 | #`(let () 73 | (define-basic-block then-block end-block) 74 | (define br-val cond-expr) 75 | #,(if which 76 | #'(llvm-cond-br br-val then-block end-block) 77 | #'(llvm-cond-br br-val end-block then-block)) 78 | 79 | (llvm-set-position then-block) 80 | (let () then-expr ...) 81 | (llvm-maybe 82 | (llvm-br end-block)) 83 | 84 | (llvm-set-position end-block) 85 | (void)))))) 86 | (values (maker #t) (maker #f)))) 87 | 88 | 89 | 90 | 91 | (define-syntax (llvm-if stx) 92 | (syntax-parse stx 93 | ((_ cond-expr:expr then-expr:expr else-expr:expr) 94 | #'(let () 95 | (define-basic-block then-block else-block merge-block) 96 | (define br-val cond-expr) 97 | (llvm-cond-br br-val then-block else-block) 98 | 99 | (llvm-set-position then-block) 100 | (define then-val then-expr) 101 | (define then-end-block (llvm-get-insert-block)) 102 | (cond 103 | [(llvm-get-terminator) 104 | (set! then-end-block #f)] 105 | [else 106 | (llvm-br merge-block)]) 107 | 108 | (llvm-set-position else-block) 109 | (define else-val else-expr) 110 | (define else-end-block (llvm-get-insert-block)) 111 | (cond 112 | [(llvm-get-terminator) 113 | (set! else-end-block #f)] 114 | [else 115 | (llvm-br merge-block)]) 116 | 117 | (llvm-set-position merge-block) 118 | (define merge-val (llvm-phi (value->llvm-type else-val))) 119 | (when then-end-block 120 | (llvm-add-incoming merge-val 121 | (cons then-val then-end-block))) 122 | (when else-end-block 123 | (llvm-add-incoming merge-val 124 | (cons else-val else-end-block))) 125 | merge-val)))) 126 | 127 | 128 | (define-syntax (llvm-for stx) 129 | (syntax-parse stx 130 | ((_ var:id init:expr test:expr inc:expr bodies:expr ...) 131 | #'(llvm-loop for-loop ((var init)) 132 | (llvm-when test 133 | (let () bodies ...) 134 | (for-loop inc)))))) 135 | 136 | (define (llvm:box v) 137 | (define ptr (llvm-alloca (value->llvm-type v))) 138 | (llvm-store v ptr) 139 | ptr) 140 | 141 | (define-syntax (llvm-define-struct stx) 142 | (define-splicing-syntax-class packed 143 | (pattern (~seq) #:attr val #'#f) 144 | (pattern (~seq #:packed) #:attr val #'#t)) 145 | (define-splicing-syntax-class omit-constructor 146 | (pattern (~seq) #:attr val #f) 147 | (pattern (~seq #:omit-constructor) #:attr val #t)) 148 | (syntax-parse stx 149 | ((_ name:id ((field:id type:expr) ...) packed:packed omit-constructor:omit-constructor) 150 | (define (merge . args) 151 | (datum->syntax #'name (string->symbol (apply string-append (map ->string args))) #'name #'name)) 152 | (define (->string v) 153 | (cond 154 | ((identifier? v) (symbol->string (syntax-e v))) 155 | ((symbol? v) (symbol->string v)))) 156 | (define/with-syntax constructor (merge 'make- #'name)) 157 | (define/with-syntax (type-val ...) (generate-temporaries #'(type ...))) 158 | (define/with-syntax (pointer-acc ...) (map (curry merge #'name '*-) (syntax->list #'(field ...)))) 159 | (define/with-syntax (reference-acc ...) (map (curry merge #'name '&-) (syntax->list #'(field ...)))) 160 | (define/with-syntax (struct-acc ...) (map (curry merge #'name '-) (syntax->list #'(field ...)))) 161 | (define/with-syntax (struct-mut ...) (map (curry merge 'set- #'name '-) (syntax->list #'(field ...)))) 162 | (define/with-syntax (index ...) (build-list (length (syntax->list #'(field ...))) identity)) 163 | (define/with-syntax define-constructor 164 | (if (attribute omit-constructor.val) 165 | #'(begin) 166 | #'(define/contract (constructor field ...) 167 | (-> (llvm:type/c type-val) ... llvm:value?) 168 | (llvm-struct field ...)))) 169 | 170 | 171 | #'(begin 172 | (define type-val type) ... 173 | (define name (llvm-struct-type type-val ... #:packed packed.val)) 174 | define-constructor 175 | (define/contract (struct-acc s) 176 | (-> (llvm:type/c name) llvm:value?) 177 | (llvm-extract-value s index)) ... 178 | (define/contract (struct-mut s val) 179 | (-> (llvm:type/c name) (llvm:type/c type-val) llvm:value?) 180 | (llvm-insert-value s val index)) ... 181 | (define/contract (pointer-acc p) 182 | (-> (llvm:type/c (llvm-pointer-type name)) llvm:reference?) 183 | (llvm:reference (llvm-gep0 p index))) ... 184 | (define/contract (reference-acc p) 185 | (-> (llvm:reference/c name) llvm:reference?) 186 | (llvm:reference (llvm-gep0 (llvm:reference-pointer p) index))) ... 187 | )))) 188 | 189 | (define-syntax (llvm-declare-function stx) 190 | (define-splicing-syntax-class visibility 191 | (pattern (~seq) #:attr val #f) 192 | (pattern (~seq #:visibility val:expr))) 193 | (define-splicing-syntax-class linkage 194 | (pattern (~seq) #:attr val #f) 195 | (pattern (~seq #:linkage val:expr))) 196 | (syntax-parse stx 197 | ((_ name:id type:expr visibility:visibility linkage:linkage) 198 | #`(begin 199 | (define name (llvm-add-function type (symbol->string 'name))) 200 | #,(if (attribute visibility.val) 201 | #'(llvm:set-visibility! name visibility.val) 202 | #'(begin)) 203 | #,(if (attribute linkage.val) 204 | #'(llvm:set-linkage! name linkage.val) 205 | #'(begin)))))) 206 | 207 | (define-syntax (llvm-implement-function stx) 208 | (syntax-parse stx 209 | ((_ name:id (args:id ...) bodies:expr ...) 210 | (with-syntax (((indicies ...) 211 | (for/list ((arg (syntax->list #'(args ...))) 212 | (i (in-naturals))) 213 | i))) 214 | #'(let () 215 | (define entry-block (llvm-add-block-to-function name #:name "entry")) 216 | (llvm-set-position entry-block) 217 | (define args (llvm-get-param indicies)) ... 218 | bodies ... 219 | (void)))))) 220 | 221 | 222 | (define-syntax (llvm-define-function stx) 223 | (define-splicing-syntax-class visibility 224 | (pattern (~seq)) 225 | (pattern (~seq #:visibility val:expr))) 226 | (define-splicing-syntax-class linkage 227 | (pattern (~seq)) 228 | (pattern (~seq #:linkage val:expr))) 229 | 230 | (syntax-parse stx 231 | ((_ name:id ((arg:id arg-type:expr) ... (~datum ->) return-type:expr) 232 | (~and 233 | (~seq keywords ...) 234 | (~seq visibility:visibility 235 | linkage:linkage)) 236 | bodies:expr ...) 237 | (with-syntax (((arg-type-val ...) (generate-temporaries #'(arg-type ...)))) 238 | (define/with-syntax function-implementation 239 | (syntax-property 240 | #'(llvm-implement-function name (arg ...) bodies ...) 241 | 'llvm-implement-function #t)) 242 | 243 | #`(begin 244 | (define arg-type-val arg-type) ... 245 | (define return-type-val return-type) 246 | (llvm-declare-function name 247 | (llvm-function-type return-type-val arg-type-val ...) 248 | keywords ...) 249 | function-implementation))))) 250 | 251 | (define-syntax (handle-bodies stx) 252 | (syntax-case stx () 253 | ((_ (last-bodies ...) body bodies ...) 254 | (let () 255 | (define new-body (local-expand #'body (syntax-local-context) #f)) 256 | (if (syntax-property new-body 'llvm-implement-function) 257 | #`(handle-bodies (#,new-body last-bodies ...) bodies ...) 258 | (syntax-case new-body (begin) 259 | ((begin form ...) 260 | #'(handle-bodies (last-bodies ...) form ... bodies ...)) 261 | (form 262 | #'(begin form 263 | (handle-bodies (last-bodies ...) bodies ...))))))) 264 | ((_ (last-bodies ...)) #'(begin last-bodies ...)))) 265 | 266 | (define-syntax (llvm-define-module stx) 267 | (define-splicing-syntax-class context 268 | (pattern (~seq))) 269 | (define-splicing-syntax-class exports 270 | (pattern (~seq) #:attr (export 1) empty) 271 | (pattern (~seq #:exports (export:id ...)))) 272 | (define-splicing-syntax-class int-type 273 | (pattern (~seq))) 274 | (define-splicing-syntax-class float-type 275 | (pattern (~seq))) 276 | 277 | 278 | (syntax-parse stx 279 | ((_ module-name:id context:context exports:exports int-type:int-type float-type:float-type 280 | bodies:expr ...) 281 | (define/with-syntax (renamed-exports ...) (generate-temporaries #'(exports.export ...))) 282 | #'(begin 283 | (define ctx (llvm-create-context)) 284 | (define exports.export #f) ... 285 | (define-syntax renamed-exports (make-rename-transformer #'exports.export)) ... 286 | (define module-name (llvm-create-module (symbol->string 'module-name) #:context ctx)) 287 | (parameterize ((current-context ctx) 288 | (current-module module-name) 289 | (current-integer-type (llvm-int32-type #:context ctx)) 290 | (current-float-type (llvm-double-type #:context ctx)) 291 | (current-builder (llvm-create-builder #:context ctx))) 292 | (set-safe:llvm-builder-ref-module! (current-builder) module-name) 293 | (handle-bodies () bodies ...) 294 | (set! renamed-exports exports.export) ... 295 | (void)))))) 296 | 297 | 298 | (define-syntax (llvm-define-global stx) 299 | (syntax-parse stx 300 | ((_ name:id init:expr) 301 | (define/with-syntax name-string (symbol->string (syntax-e #'name))) 302 | #'(begin 303 | (define value init) 304 | (define name (llvm-add-global (value->llvm-type value) name-string)) 305 | (llvm:set-initializer! name value))))) 306 | 307 | (define-syntax (llvm-loop stx) 308 | (syntax-parse stx 309 | ((_ name:id ((arg:id init:expr) ...) bodies:expr ...) 310 | (define/with-syntax (arg2 ...) (generate-temporaries #'(arg ...))) 311 | (define/with-syntax (arg-string ...) 312 | (map (compose symbol->string syntax-e) (syntax->list #'(arg ...)))) 313 | (define/with-syntax (arg-value ...) (generate-temporaries #'(arg ...))) 314 | (define/with-syntax block-name (string-append "begin-" (symbol->string (syntax-e #'name)))) 315 | 316 | #'(let ((arg-value init) ...) 317 | (define incoming-block (llvm-get-insert-block)) 318 | (define begin-block (llvm-add-block #:name block-name)) 319 | (llvm-br begin-block) 320 | (llvm-set-position begin-block) 321 | (define (name #:builder (builder (current-builder)) arg2 ...) 322 | (let ((current-block (llvm-get-insert-block #:builder builder))) 323 | (llvm-add-incoming arg (cons arg2 current-block)) ... 324 | (llvm-br begin-block #:builder builder))) 325 | (define arg (llvm-phi (value->llvm-type arg-value) #:name arg-string)) ... 326 | (llvm-add-incoming arg (cons arg-value incoming-block)) ... 327 | bodies ...)))) 328 | 329 | 330 | -------------------------------------------------------------------------------- /private/simple/functions.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/contract 5 | unstable/contract 6 | "../ffi/safe.rkt" 7 | "parameters.rkt" 8 | "predicates.rkt" 9 | "convertible.rkt" 10 | "types.rkt") 11 | 12 | (provide 13 | (contract-out 14 | (llvm:function-pointer? predicate/c) 15 | 16 | (llvm-add-function 17 | (->* (llvm:function-type? string?) 18 | (#:module llvm:module?) llvm:value?)) 19 | 20 | (llvm-get-named-function 21 | (->* (string?) (#:module llvm:module?) llvm:value?)))) 22 | 23 | 24 | (define (llvm:function-pointer? v) 25 | (and (llvm:value? v) 26 | (let ((type (value->llvm-type v))) 27 | (and (llvm:pointer-type? type) 28 | (llvm:function-type? (llvm-get-element-type type)))))) 29 | 30 | 31 | (define (llvm-add-function type name #:module (module (current-module))) 32 | (LLVMAddFunction module name type)) 33 | 34 | (define (llvm-get-named-function name #:module (module (current-module))) 35 | (LLVMGetNamedFunction module name)) 36 | 37 | -------------------------------------------------------------------------------- /private/simple/generic.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | (only-in ffi/unsafe cpointer?) 5 | racket/contract 6 | unstable/contract 7 | "../ffi/safe.rkt" 8 | "parameters.rkt" 9 | "types.rkt" 10 | "modules.rkt") 11 | 12 | (provide 13 | (contract-out 14 | (llvm:int->generic (->* (exact-integer?) (#:type llvm:integer-type? #:signed boolean?) llvm-generic-value?)) 15 | (llvm:int8->generic (->* (exact-integer?) (#:signed boolean?) llvm-generic-value?)) 16 | (llvm:int32->generic (->* (exact-integer?) (#:signed boolean?) llvm-generic-value?)) 17 | 18 | 19 | 20 | (llvm:float->generic (->* (real?) (#:type (or/c llvm:float-type? 'single 'double)) llvm-generic-value?)) 21 | (llvm:single->generic (-> real? llvm-generic-value?)) 22 | (llvm:double->generic (-> real? llvm-generic-value?)) 23 | 24 | (llvm:pointer->generic (-> cpointer? llvm-generic-value?)) 25 | 26 | (llvm:generic-get-int-width (-> llvm-generic-value? exact-positive-integer?)) 27 | (llvm:generic->int (->* (llvm-generic-value?) (#:signed boolean?) exact-integer?)) 28 | (llvm:generic->pointer (-> llvm-generic-value? cpointer?)) 29 | 30 | (llvm:generic->float (->* (llvm-generic-value?) (#:type (or/c 'single 'double llvm:float-type?)) real?)) 31 | (llvm:generic->single (->* (llvm-generic-value?) real?)) 32 | (llvm:generic->double (->* (llvm-generic-value?) real?)) 33 | 34 | (llvm-generic-value? predicate/c))) 35 | 36 | ;TODO implement 37 | (define (llvm-generic-value? v) #t) 38 | 39 | 40 | 41 | ;Precreated types 42 | (define context (llvm-create-context)) 43 | (define single (llvm-single-type #:context context)) 44 | (define double (llvm-double-type #:context context)) 45 | (define int8 (llvm-int8-type #:context context)) 46 | (define int32 (llvm-int32-type #:context context)) 47 | 48 | 49 | (define (llvm:int->generic n #:type (type (current-integer-type)) #:signed (signed #t)) 50 | (LLVMCreateGenericValueOfInt type n signed)) 51 | 52 | ;TODO clean this up 53 | (define (llvm:int8->generic n #:signed (signed #t)) 54 | (LLVMCreateGenericValueOfInt int8 n signed)) 55 | (define (llvm:int32->generic n #:signed (signed #t)) 56 | (LLVMCreateGenericValueOfInt int32 n signed)) 57 | 58 | 59 | 60 | (define (llvm:pointer->generic ptr) 61 | (LLVMCreateGenericValueOfPointer ptr)) 62 | 63 | 64 | 65 | (define (llvm:float->generic x #:type (type (current-float-type))) 66 | (let ((type (cond 67 | ((llvm:float-type? type) type) 68 | ((equal? 'double type) double) 69 | ((equal? 'single type) single)))) 70 | (LLVMCreateGenericValueOfFloat type x))) 71 | 72 | (define (llvm:double->generic x) 73 | (llvm:float->generic x #:type double)) 74 | 75 | (define (llvm:single->generic x) 76 | (llvm:float->generic x #:type single)) 77 | 78 | 79 | 80 | (define (llvm:generic-get-int-width gen) 81 | (LLVMGenericValueIntWidth gen)) 82 | 83 | 84 | (define (llvm:generic->int gen #:signed (signed #t)) 85 | (LLVMGenericValueToInt gen signed)) 86 | 87 | (define (llvm:generic->pointer gen) 88 | (LLVMGenericValueToPointer gen)) 89 | 90 | (define (llvm:generic->float gen #:type (type (current-float-type))) 91 | (let ((type (cond 92 | ((llvm:float-type? type) type) 93 | ((equal? 'double type) double) 94 | ((equal? 'single type) single)))) 95 | (LLVMGenericValueToFloat type gen))) 96 | 97 | 98 | (define (llvm:generic->double x) 99 | (llvm:generic->float x #:type double)) 100 | 101 | (define (llvm:generic->single x) 102 | (llvm:generic->float x #:type single)) 103 | 104 | 105 | 106 | 107 | -------------------------------------------------------------------------------- /private/simple/globals.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | (for-syntax racket/base) 5 | racket/contract 6 | unstable/contract 7 | "../ffi/safe.rkt" 8 | "util.rkt" 9 | "types.rkt" 10 | "parameters.rkt" 11 | "predicates.rkt" 12 | "convertible.rkt") 13 | 14 | (provide 15 | (contract-out 16 | 17 | (llvm:global-variable? predicate/c) 18 | (llvm:global? predicate/c) 19 | 20 | 21 | (llvm-get-named-global (->* (string?) (#:module llvm:module?) llvm:value?)) 22 | (llvm-add-global 23 | (->* (llvm:type? string?) (#:module llvm:module?) llvm:value?)) 24 | ;TODO look into changing the name of this 25 | (llvm-global-string-ptr 26 | (->* (string?) (#:builder llvm:builder? #:name string?) llvm:value?)) 27 | 28 | 29 | 30 | (llvm:get-visibility (-> llvm:global? visibility/c)) 31 | (llvm:set-visibility! (-> llvm:global? visibility/c void?)) 32 | 33 | (llvm:get-linkage (-> llvm:global? linkage/c)) 34 | (llvm:set-linkage! (-> llvm:global? linkage/c void?)) 35 | 36 | (llvm:get-alignment (-> llvm:global? alignment/c)) 37 | (llvm:set-alignment! (-> llvm:global? alignment/c void?)) 38 | 39 | (llvm:get-section (-> llvm:global? string?)) 40 | (llvm:set-section! (-> llvm:global? string? void?)) 41 | 42 | (llvm:get-initializer (-> llvm:global-variable? llvm:value?)) 43 | (llvm:set-initializer! set-initializer/c) 44 | 45 | (llvm:is-thread-local? (-> llvm:global-variable? boolean?)) 46 | (llvm:set-thread-local! (-> llvm:global-variable? boolean? void?)) 47 | 48 | (llvm:is-global-constant? (-> llvm:global-variable? boolean?)) 49 | (llvm:set-global-constant! (-> llvm:global-variable? boolean? void?)))) 50 | 51 | 52 | ;TODO implement 53 | (define (llvm:global? v) #t) 54 | (define (llvm:global-variable? v) #t) 55 | 56 | 57 | (define (llvm-get-named-global name #:module (module (current-module))) 58 | (LLVMGetNamedGlobal module name)) 59 | 60 | 61 | (define (llvm-add-global type name #:module (module (current-module))) 62 | (LLVMAddGlobal module type name)) 63 | 64 | (define (llvm-global-string-ptr string #:builder (builder (current-builder)) #:name (name "")) 65 | (LLVMBuildGlobalStringPtr builder string name)) 66 | 67 | 68 | 69 | 70 | 71 | 72 | (define set-initializer/c 73 | (->i ((global-var llvm:global-variable?) 74 | (value llvm-value/c)) 75 | #:pre/name (global-var value) 76 | "Initializer type does not match global type" 77 | (equal? (llvm-get-element-type (value->llvm-type global-var)) 78 | (value->llvm-type value)) 79 | (result void?))) 80 | (define alignment/c 81 | (or/c 0 power-of-two?)) 82 | 83 | 84 | 85 | (define-syntax (define-converter stx) 86 | (syntax-case stx () 87 | ((_ name ((sym enum) ...)) 88 | (let () 89 | (define (get-id str) 90 | (datum->syntax #'name 91 | (string->symbol (format str (syntax-e #'name))))) 92 | 93 | (with-syntax ((->enum (get-id "~a->enum")) 94 | (enum-> (get-id "enum->~a")) 95 | (contract (get-id "~a/c"))) 96 | #'(begin 97 | (define contract (or/c 'sym ...)) 98 | (define (->enum v) 99 | (case v 100 | ((sym) 'enum) ...)) 101 | (define (enum-> v) 102 | (case v 103 | ((enum) 'sym) ...)))))))) 104 | 105 | (define-converter visibility 106 | ((default LLVMDefaultVisibility) 107 | (hidden LLVMHiddenVisibility) 108 | (protected LLVMProtectedVisibility))) 109 | 110 | 111 | (define-converter linkage 112 | ((external LLVMExternalLinkage) 113 | (available-externally LLVMAvailableExternallyLinkage) 114 | (link-once-any LLVMLinkOnceAnyLinkage) 115 | (link-once-odr LLVMLinkOnceODRLinkage) 116 | (weak-any LLVMWeakAnyLinkage) 117 | (weak-odr LLVMWeakODRLinkage) 118 | (appending LLVMAppendingLinkage) 119 | (internal LLVMInternalLinkage) 120 | (private LLVMPrivateLinkage) 121 | (dll-import LLVMDLLImportLinkage) 122 | (dll-export LLVMDLLExportLinkage) 123 | (external-weak LLVMExternalWeakLinkage) 124 | (common LLVMCommonLinkage) 125 | (linker-private LLVMLinkerPrivateLinkage) 126 | (linker-private-weak LLVMLinkerPrivateWeakLinkage) 127 | (linker-private-weak-default-auto LLVMLinkerPrivateWeakDefAutoLinkage))) 128 | 129 | 130 | 131 | 132 | (define (llvm:get-section global) 133 | (LLVMGetSection global)) 134 | (define (llvm:set-section! global section) 135 | (LLVMSetSection global section)) 136 | 137 | (define (llvm:get-alignment global) 138 | (LLVMGetAlignment global)) 139 | (define (llvm:set-alignment! global alignment) 140 | (LLVMSetAlignment global alignment)) 141 | 142 | (define (llvm:get-visibility global) 143 | (enum->visibility (LLVMGetVisibility global))) 144 | (define (llvm:set-visibility! global visibility) 145 | (LLVMSetVisibility global (visibility->enum visibility))) 146 | 147 | (define (llvm:get-linkage global) 148 | (enum->linkage (LLVMGetLinkage global))) 149 | (define (llvm:set-linkage! global linkage) 150 | (LLVMSetLinkage global (linkage->enum linkage))) 151 | 152 | 153 | (define (llvm:get-initializer global-var) 154 | (LLVMGetInitializer global-var)) 155 | (define (llvm:set-initializer! global-var value) 156 | (LLVMSetInitializer global-var (value->llvm value))) 157 | 158 | (define (llvm:is-thread-local? global-val) 159 | (LLVMIsThreadLocal global-val)) 160 | (define (llvm:set-thread-local! global-val bool) 161 | (LLVMSetThreadLocal global-val bool)) 162 | 163 | (define (llvm:is-global-constant? global-val) 164 | (LLVMIsGlobalConstant global-val)) 165 | (define (llvm:set-global-constant! global-val bool) 166 | (LLVMSetGlobalConstant global-val bool)) 167 | 168 | 169 | -------------------------------------------------------------------------------- /private/simple/indexed-types.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/contract 5 | racket/list 6 | "../ffi/safe.rkt" 7 | "predicates.rkt" 8 | "convertible.rkt" 9 | "types.rkt") 10 | 11 | (provide 12 | (contract-out 13 | (llvm-valid-gep-indices? (-> llvm:type? (listof llvm-integer/c) boolean?)) 14 | (llvm-gep-type 15 | (->i ((type llvm:type?) 16 | (indices (listof llvm-integer/c))) 17 | #:pre (type indices) 18 | (llvm-valid-gep-indices? type indices) 19 | (_ llvm:type?))) 20 | 21 | 22 | (llvm-is-valid-type-index 23 | (-> llvm:pointer-type? 24 | llvm-integer/c 25 | boolean?)) 26 | 27 | (llvm-get-type-at-index 28 | (->i ((type llvm:pointer-type?) 29 | (index llvm-integer/c)) 30 | #:pre (type index) 31 | (llvm-is-valid-type-index type index) 32 | (_ llvm:type?))))) 33 | 34 | 35 | 36 | 37 | (define (llvm-get-type-at-index type idx) 38 | (LLVMGetTypeAtIndex type (value->llvm idx))) 39 | 40 | (define (llvm-is-valid-type-index type idx) 41 | (LLVMIsValidTypeIndex type (value->llvm idx))) 42 | 43 | (define (llvm-valid-gep-indices? type indices) 44 | (let ((type (llvm-gep-type type indices))) 45 | (if type #t #f))) 46 | 47 | 48 | ;First index is checked by contract 49 | (define (llvm-gep-type type indices) 50 | (and (equal? (llvm-get-type-kind type) 51 | 'LLVMPointerTypeKind) 52 | (let loop ((type (llvm-get-element-type type)) (indices (rest indices))) 53 | (or (and (empty? indices) type) 54 | (let ((kind (llvm-get-type-kind type))) 55 | (and (memq kind '(LLVMStructTypeKind LLVMArrayTypeKind LLVMVectorTypeKind)) 56 | (llvm-is-valid-type-index type (first indices)) 57 | (loop (llvm-get-type-at-index type (first indices)) (rest indices)))))))) 58 | 59 | -------------------------------------------------------------------------------- /private/simple/intrinsics.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | 5 | (require 6 | "../ffi/safe.rkt" 7 | "convertible.rkt" 8 | "types.rkt" 9 | "builder.rkt" 10 | "misc-instructions.rkt" 11 | "predicates.rkt" 12 | "parameters.rkt") 13 | (require racket/contract) 14 | 15 | (provide 16 | (contract-out 17 | (llvm:sqrt (->* (llvm-float/c) 18 | (#:builder llvm:builder? 19 | #:name string?) 20 | llvm-float/c)))) 21 | 22 | 23 | 24 | (define (sqrt-intrinsic module ty) 25 | (LLVMGetIntrinsic module 'sqrt (list ty))) 26 | 27 | (define (llvm:sqrt v #:builder (builder (current-builder)) #:name (name "")) 28 | (let* ((v (value->llvm v)) 29 | (ty (value->llvm-type v))) 30 | (llvm-call (sqrt-intrinsic (builder->module builder) ty) 31 | v #:builder builder #:name name))) 32 | 33 | -------------------------------------------------------------------------------- /private/simple/memory.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/contract 5 | "../ffi/safe.rkt" 6 | "parameters.rkt" 7 | "predicates.rkt" 8 | "convertible.rkt" 9 | "indexed-types.rkt" 10 | "types.rkt") 11 | 12 | (provide 13 | (contract-out 14 | (llvm-alloca alloc/c) 15 | (llvm-array-alloca array-alloc/c) 16 | (llvm-malloc alloc/c) 17 | (llvm-array-malloc array-alloc/c) 18 | (llvm-load load/c) 19 | (llvm-store store/c) 20 | (llvm-gep gep/c) 21 | (llvm-gep0 gep/c))) 22 | 23 | 24 | (define load/c 25 | (->* (llvm-any-pointer/c) 26 | (#:builder llvm:builder? 27 | #:name string?) 28 | llvm:value?)) 29 | 30 | 31 | (define store/c 32 | (->i ((value llvm-value/c) 33 | (pointer llvm-any-pointer/c)) 34 | (#:builder (builder llvm:builder?)) 35 | #:pre/name (value pointer) 36 | "Pointer and value Types do not match" 37 | (equal? 38 | (llvm-get-element-type (value->llvm-type pointer)) 39 | (value->llvm-type value)) 40 | (_ llvm:value?))) 41 | 42 | (define gep/c 43 | (->i ((pointer llvm:value/c)) 44 | (#:builder (builder llvm:builder?) 45 | #:name (name string?)) 46 | #:rest (args (listof llvm-integer/c)) 47 | #:pre/name (pointer args) 48 | "Invalid indices" 49 | (llvm-valid-gep-indices? (value->llvm-type pointer) (map integer->llvm args)) 50 | (_ llvm:value?))) 51 | 52 | 53 | (define gep0/c 54 | (->i ((pointer llvm:value/c)) 55 | (#:builder (builder llvm:builder?) 56 | #:name (name string?)) 57 | #:rest (args (listof llvm-integer/c)) 58 | #:pre/name (pointer args) 59 | "Invalid indices" 60 | (llvm-valid-gep-indices? (value->llvm-type pointer) (map integer->llvm (cons 0 args))) 61 | (_ llvm:value?))) 62 | 63 | 64 | (define alloc/c 65 | (->* (llvm:type?) 66 | (#:builder llvm:builder? 67 | #:name string?) 68 | llvm:value?)) 69 | 70 | (define array-alloc/c 71 | (->* (llvm:type? 72 | llvm-integer/c) 73 | (#:builder llvm:builder? 74 | #:name string?) 75 | llvm:value?)) 76 | 77 | 78 | 79 | 80 | 81 | (define (llvm-load pointer #:builder (builder (current-builder)) #:name (name "")) 82 | (LLVMBuildLoad builder pointer name)) 83 | 84 | (define (llvm-store value pointer #:builder (builder (current-builder))) 85 | (LLVMBuildStore builder (value->llvm value) pointer)) 86 | 87 | 88 | (define (llvm-alloca type #:builder (builder (current-builder)) #:name (name "")) 89 | (LLVMBuildAlloca builder type name)) 90 | 91 | (define (llvm-array-alloca type size #:builder (builder (current-builder)) #:name (name "")) 92 | (LLVMBuildArrayAlloca builder type (integer->llvm size) name)) 93 | 94 | 95 | (define (llvm-malloc type #:builder (builder (current-builder)) #:name (name "")) 96 | (LLVMBuildMalloc builder type name)) 97 | 98 | (define (llvm-array-malloc type size #:builder (builder (current-builder)) #:name (name "")) 99 | (LLVMBuildArrayMalloc builder type (integer->llvm size) name)) 100 | 101 | 102 | (define (llvm-gep pointer #:builder (builder (current-builder)) #:name (name "") . indicies) 103 | (LLVMBuildGEP builder pointer (map integer->llvm indicies) name)) 104 | 105 | (define (llvm-gep0 pointer #:builder (builder (current-builder)) #:name (name "") . indicies) 106 | (LLVMBuildGEP builder pointer (map integer->llvm (cons 0 indicies)) name)) 107 | 108 | -------------------------------------------------------------------------------- /private/simple/misc-instructions.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/list 5 | racket/contract 6 | "../ffi/safe.rkt" 7 | "util.rkt" 8 | "parameters.rkt" 9 | "predicates.rkt" 10 | "builder.rkt" 11 | "convertible.rkt") 12 | 13 | 14 | (provide 15 | (contract-out 16 | (llvm-ret (->* () (llvm-value/c #:builder llvm:builder?) llvm:value?)) 17 | (llvm-cond-br (->* (llvm-boolean/c llvm:basic-block? llvm:basic-block?) 18 | (#:builder llvm:builder?) 19 | llvm:value?)) 20 | (llvm-br (->* (llvm:basic-block?) 21 | (#:builder llvm:builder?) 22 | llvm:value?)) 23 | 24 | (llvm-phi (->* (llvm:type?) 25 | (#:builder llvm:builder? 26 | #:name string?) 27 | llvm:value?)) 28 | 29 | (llvm-add-incoming 30 | (->* (llvm:value?) 31 | () 32 | #:rest (listof (or/c (cons/c llvm-value/c llvm:basic-block?) llvm:value?)) 33 | void?)) 34 | 35 | 36 | (llvm-get-param (->* (integer?) (#:function llvm:value?) llvm:value?)) 37 | (llvm-call (->* (llvm:value?) (#:builder llvm:builder? #:name string?) #:rest (listof llvm-value/c) llvm:value?)) 38 | (llvm-call* (->* (llvm:value?) (#:builder llvm:builder? #:name string?) #:rest (list*/c llvm-value/c) llvm:value?)))) 39 | 40 | 41 | 42 | (define (llvm-get-param index #:function (function (builder->function (current-builder)))) 43 | (LLVMGetParam function index)) 44 | 45 | (define (llvm-ret (val (void)) #:builder (builder (current-builder))) 46 | (if (void? val) 47 | (LLVMBuildRetVoid builder) 48 | (LLVMBuildRet builder (value->llvm val)))) 49 | 50 | 51 | 52 | (define (llvm-cond-br cond true-block false-block #:builder (builder (current-builder))) 53 | (LLVMBuildCondBr builder (boolean->llvm cond) true-block false-block)) 54 | 55 | (define (llvm-br block #:builder (builder (current-builder))) 56 | (LLVMBuildBr builder block)) 57 | 58 | 59 | (define (llvm-phi type #:builder (builder (current-builder)) #:name (name "")) 60 | (LLVMBuildPhi builder type name)) 61 | 62 | ;TODO change the API on this 63 | (define (llvm-add-incoming phi . input-values) 64 | (define (extract-value v) 65 | (if (cons? v) (value->llvm (car v)) v)) 66 | (define (extract-block v) 67 | (if (cons? v) (cdr v) (LLVMGetInstructionParent v))) 68 | 69 | (define values (map extract-value input-values)) 70 | (define blocks (map extract-block input-values)) 71 | 72 | (LLVMAddIncoming phi values blocks)) 73 | 74 | 75 | (define (llvm-call function #:builder (builder (current-builder)) #:name (name "") . arguments) 76 | (LLVMBuildCall builder function (map value->llvm arguments) name)) 77 | 78 | (define (llvm-call* function #:builder (builder (current-builder)) #:name (name "") . arguments) 79 | (LLVMBuildCall builder function (map value->llvm (apply list* arguments)) name)) 80 | 81 | -------------------------------------------------------------------------------- /private/simple/modules.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/contract 5 | "../ffi/safe.rkt" 6 | "predicates.rkt" 7 | "parameters.rkt") 8 | 9 | 10 | (provide 11 | (contract-out 12 | (llvm-create-context (-> llvm:context?)) 13 | (llvm-create-module 14 | (->* () (string? #:context llvm:context?) llvm:module?)) 15 | 16 | 17 | (llvm-verify-module (->* () (llvm:module?) (or/c #f string?))) 18 | (llvm-assert-module-valid (->* () (llvm:module?) void?)) 19 | (llvm-module-description (->* () (llvm:module?) string?)) 20 | 21 | 22 | (llvm-create-module-from-bitcode-file 23 | (->* (path-string?) (#:context llvm:context?) llvm:module?)) 24 | (llvm-write-bitcode-to-file 25 | (case-> (-> path-string? void?) 26 | (-> llvm:module? path-string? void?))))) 27 | 28 | (define (llvm-create-context) 29 | (LLVMContextCreate)) 30 | 31 | (define (llvm-create-module (name "") #:context (context (current-context))) 32 | (LLVMModuleCreateWithNameInContext name context)) 33 | 34 | (define (llvm-create-module-from-bitcode-file path #:context (context (current-context))) 35 | (LLVMParseBitcodeInContext 36 | context 37 | (LLVMCreateMemoryBufferWithContentsOfFile path))) 38 | 39 | (define (llvm-module-description (module (current-module))) 40 | (LLVMGetModuleDescription module)) 41 | 42 | (define llvm-write-bitcode-to-file 43 | (case-lambda 44 | ((module path) 45 | (let ((err (LLVMWriteBitcodeToFile module path))) 46 | (unless (zero? err) 47 | (error 'llvm-write-bitcode-to-file "Error ~a" err)))) 48 | ((path) 49 | (llvm-write-bitcode-to-file (current-module) path)))) 50 | 51 | (define (llvm-verify-module (module (current-module))) 52 | (LLVMVerifyModule module 'LLVMReturnStatusAction)) 53 | 54 | (define (llvm-assert-module-valid (module (current-module))) 55 | (let ((err (llvm-verify-module module))) 56 | (void 57 | (and err 58 | (error 'assert-module-valid 59 | "Bad module: ~n~a" err))))) 60 | 61 | 62 | 63 | -------------------------------------------------------------------------------- /private/simple/parameters.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/contract 5 | "../ffi/safe.rkt" 6 | "predicates.rkt" 7 | "primitive-types.rkt") 8 | 9 | ;TODO contracts 10 | (provide 11 | (contract-out 12 | (current-builder (parameter/c llvm:builder?)) 13 | (current-context (parameter/c llvm:context?)) 14 | (current-module (parameter/c llvm:module?)) 15 | (current-integer-type (parameter/c llvm:integer-type?)) 16 | (current-float-type (parameter/c llvm:float-type?)) 17 | (current-boolean-type (-> llvm:integer-type?)))) 18 | 19 | (define current-builder 20 | (make-derived-parameter 21 | (make-parameter #f) 22 | (lambda (x) x) 23 | (lambda (builder) 24 | (or builder 25 | (error 'current-builder "Current builder was never set"))))) 26 | 27 | 28 | (define current-module 29 | (make-derived-parameter 30 | (make-parameter #f) 31 | (lambda (x) x) 32 | (lambda (module) 33 | (or module 34 | (error 'current-module "Current module was never set"))))) 35 | 36 | 37 | (define current-context 38 | (make-derived-parameter 39 | (make-parameter #f) 40 | (lambda (x) x) 41 | (lambda (context) 42 | (or context 43 | (error 'current-context "Current context was never set"))))) 44 | 45 | (define current-integer-type 46 | (make-derived-parameter 47 | (make-parameter #f) 48 | (lambda (x) x) 49 | (lambda (int-type) 50 | (or int-type 51 | (error 'current-integer-type "Current integer-type was never set"))))) 52 | 53 | 54 | (define current-float-type 55 | (make-derived-parameter 56 | (make-parameter #f) 57 | (lambda (x) x) 58 | (lambda (float-type) 59 | (or float-type 60 | (error 'float-type "Current float-type was never set"))))) 61 | 62 | 63 | (define (current-boolean-type) 64 | (LLVMInt1TypeInContext (current-context))) 65 | 66 | -------------------------------------------------------------------------------- /private/simple/predicates.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/contract 5 | unstable/contract 6 | "../safe/structs.rkt") 7 | 8 | 9 | (provide 10 | (contract-out 11 | (llvm:value? predicate/c) 12 | (llvm:type? predicate/c) 13 | (llvm:module? predicate/c) 14 | (llvm:context? predicate/c) 15 | (llvm:basic-block? predicate/c) 16 | (llvm:builder? predicate/c))) 17 | 18 | (define (llvm:value? v) 19 | (llvm-value-ref? v)) 20 | 21 | (define (llvm:type? t) 22 | (llvm-type-ref? t)) 23 | 24 | (define (llvm:module? m) 25 | (llvm-module-ref? m)) 26 | 27 | (define (llvm:context? m) 28 | (llvm-context-ref? m)) 29 | 30 | (define (llvm:builder? b) 31 | (llvm-builder-ref? b)) 32 | 33 | (define (llvm:basic-block? b) 34 | (llvm-basic-block-ref? b)) 35 | 36 | -------------------------------------------------------------------------------- /private/simple/primitive-types.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | "predicates.rkt" 5 | "../ffi/safe.rkt") 6 | 7 | (provide 8 | llvm:integer-type? 9 | llvm:float-type? 10 | llvm-get-type-kind) 11 | 12 | (define (llvm:integer-type? type) 13 | (and (llvm:type? type) 14 | (let ((type-kind (llvm-get-type-kind type))) 15 | (equal? type-kind 'LLVMIntegerTypeKind)))) 16 | 17 | (define (llvm:float-type? type) 18 | (and (llvm:type? type) 19 | (let ((type-kind (llvm-get-type-kind type))) 20 | (member type-kind 21 | '(LLVMFloatTypeKind 22 | LLVMDoubleTypeKind 23 | LLVMX86_FP80TypeKind 24 | LLVMFP128TypeKind 25 | LLVMPPC_FP128TypeKind)) 26 | #t))) 27 | 28 | (define (llvm-get-type-kind type) 29 | (LLVMGetTypeKind type)) 30 | 31 | -------------------------------------------------------------------------------- /private/simple/references.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require 3 | racket/contract 4 | unstable/contract 5 | "convertible.rkt" 6 | "memory.rkt" 7 | "types.rkt" 8 | "indexed-types.rkt" 9 | "memory.rkt" 10 | "parameters.rkt" 11 | "predicates.rkt") 12 | 13 | (provide 14 | (contract-out 15 | 16 | (llvm:reference? predicate/c) 17 | (llvm:reference (-> llvm-any-pointer/c llvm:reference?)) 18 | (llvm:reference-pointer (-> llvm:reference? llvm-any-pointer/c)) 19 | (llvm:reference/c (-> llvm:type? contract?)) 20 | (llvm:ger ger/c) 21 | (llvm:ger0 ger0/c) 22 | (llvm:set set/c) 23 | (llvm:read read/c))) 24 | 25 | ;TODO add contract 26 | (provide 27 | llvm:set-multiple) 28 | 29 | ;TODO add printing 30 | (struct llvm:reference (pointer) 31 | #:property prop:llvm-value 32 | (lambda (ref) 33 | (define pointer (llvm:reference-pointer ref)) 34 | (values (llvm-load pointer) 35 | (llvm-get-element-type (value->llvm-type pointer))))) 36 | 37 | 38 | (define set/c 39 | (->i ((reference llvm:reference?) 40 | (value llvm:value/c)) 41 | (#:builder (builder llvm:builder?)) 42 | #:pre/name (reference value) 43 | "Type of value does not match type of reference" 44 | (equal? 45 | (llvm-get-element-type (value->llvm-type (llvm:reference-pointer reference))) 46 | (value->llvm-type value)) 47 | (_ llvm:value?))) 48 | 49 | (define read/c 50 | (->* (llvm:reference?) 51 | (#:builder llvm:builder? 52 | #:name string?) 53 | llvm:value?)) 54 | 55 | (define ger/c 56 | (->i ((reference llvm:reference?)) 57 | (#:builder (builder llvm:builder?) 58 | #:name (name string?)) 59 | #:rest (args (listof llvm-integer/c)) 60 | #:pre/name (reference args) 61 | "Invalid indices" 62 | (llvm-valid-gep-indices? (value->llvm-type (llvm:reference-pointer reference)) (map integer->llvm args)) 63 | (_ llvm:reference?))) 64 | 65 | 66 | (define ger0/c 67 | (->i ((reference llvm:reference?)) 68 | (#:builder (builder llvm:builder?) 69 | #:name (name string?)) 70 | #:rest (args (listof llvm-integer/c)) 71 | #:pre/name (reference args) 72 | "Invalid indices" 73 | (llvm-valid-gep-indices? (value->llvm-type (llvm:reference-pointer reference)) (map integer->llvm (cons 0 args))) 74 | (_ llvm:reference?))) 75 | 76 | 77 | 78 | 79 | (define (llvm:set-multiple references #:builder (builder (current-builder)) . values) 80 | (for ((ref references) (v values)) 81 | (llvm:set ref v #:builder builder))) 82 | 83 | (define (llvm:set reference value #:builder (builder (current-builder))) 84 | (llvm-store value (llvm:reference-pointer reference) #:builder builder)) 85 | 86 | (define (llvm:read reference #:builder (builder (current-builder)) #:name (name "")) 87 | (llvm-load (llvm:reference-pointer reference) #:builder builder #:name name)) 88 | 89 | (define (llvm:reference/c type) 90 | (struct/c llvm:reference (llvm:type/c (llvm-pointer-type type)))) 91 | 92 | (define (llvm:ger reference #:builder (builder (current-builder)) #:name (name "") . indices) 93 | (llvm:reference (apply llvm-gep (llvm:reference-pointer reference) #:builder builder #:name name indices))) 94 | 95 | (define (llvm:ger0 reference #:builder (builder (current-builder)) #:name (name "") . indices) 96 | (llvm:reference (apply llvm-gep0 (llvm:reference-pointer reference) #:builder builder #:name name indices))) 97 | -------------------------------------------------------------------------------- /private/simple/runtime.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | "../ffi/safe.rkt" 5 | "parameters.rkt" 6 | "globals.rkt" 7 | "predicates.rkt" 8 | "convertible.rkt" 9 | racket/contract 10 | unstable/contract) 11 | (require (only-in ffi/unsafe cpointer?) "types.rkt") 12 | 13 | 14 | (provide 15 | (contract-out 16 | 17 | (llvm:optimize-module (->* () (llvm:module?) boolean?)) 18 | (llvm:create-jit (->* () (llvm:module? #:level (one-of/c 0 1 2 3)) llvm:execution-engine?)) 19 | (llvm:extract-function (-> llvm:execution-engine? 20 | llvm:value? 21 | procedure?)) 22 | (llvm:extract-global (-> llvm:execution-engine? 23 | llvm:global-variable? 24 | cpointer?)) 25 | (llvm:execution-engine? predicate/c))) 26 | 27 | 28 | ;TODO implement 29 | (define (llvm:execution-engine? v) #t) 30 | 31 | (define (llvm:optimize-module (module (current-module))) 32 | (LLVMOptimizeModule module)) 33 | 34 | 35 | (define (llvm:create-jit (module (current-module)) #:level (level 3)) 36 | (LLVMCreateJITCompilerForModule module level)) 37 | 38 | (define (llvm:extract-function ee function) 39 | (let ((runner (if (equal? (llvm-get-type-kind 40 | (llvm-get-return-type 41 | (llvm-get-element-type 42 | (value->llvm-type function)))) 43 | 'LLVMVoidTypeKind) 44 | LLVMRunVoidFunction LLVMRunFunction))) 45 | (lambda args 46 | (runner ee function args)))) 47 | 48 | (define (llvm:extract-global ee global) 49 | (LLVMGetPointerToGlobal ee global)) 50 | -------------------------------------------------------------------------------- /private/simple/types.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | 5 | (require 6 | racket/contract 7 | unstable/contract 8 | "../ffi/safe.rkt" 9 | "util.rkt" 10 | "parameters.rkt" 11 | "predicates.rkt" 12 | "primitive-types.rkt") 13 | 14 | ;TODO add contracts 15 | (provide llvm-array-type 16 | llvm-vector-type 17 | llvm-struct-type 18 | llvm-struct-type* 19 | llvm-named-struct-type) 20 | 21 | (provide 22 | (contract-out 23 | 24 | 25 | 26 | ;Deconstructors 27 | (llvm-get-type-kind (-> llvm:type? symbol?)) 28 | (llvm-get-element-type (-> llvm:sequential-type? llvm:type?)) 29 | (llvm-get-return-type (-> llvm:function-type? llvm:type?)) 30 | 31 | ;Constructors 32 | (llvm-int-type (-> llvm:integer-type?)) 33 | (llvm-int1-type (->* () (#:context llvm:context?) llvm:integer-type?)) 34 | (llvm-int8-type (->* () (#:context llvm:context?) llvm:integer-type?)) 35 | (llvm-int16-type (->* () (#:context llvm:context?) llvm:integer-type?)) 36 | (llvm-int32-type (->* () (#:context llvm:context?) llvm:integer-type?)) 37 | (llvm-int64-type (->* () (#:context llvm:context?) llvm:integer-type?)) 38 | 39 | 40 | (llvm-single-type (->* () (#:context llvm:context?) llvm:float-type?)) 41 | (llvm-double-type (->* () (#:context llvm:context?) llvm:float-type?)) 42 | (llvm-fp128-type (->* () (#:context llvm:context?) llvm:float-type?)) 43 | (llvm-x86-fp80-type (->* () (#:context llvm:context?) llvm:float-type?)) 44 | (llvm-ppc-fp128-type (->* () (#:context llvm:context?) llvm:float-type?)) 45 | 46 | ;Mutators 47 | (llvm-named-struct-type-set-body! 48 | (->* (llvm:unset-named-struct-type?) 49 | (#:packed boolean?) 50 | #:rest (listof llvm:type?) 51 | void?)) 52 | (llvm-named-struct-type-set-body*! 53 | (->* (llvm:unset-named-struct-type?) 54 | (#:packed boolean?) 55 | #:rest (list*/c llvm:type?) 56 | void?)) 57 | 58 | (llvm-pointer-type (->* (llvm:type?) (#:address-space integer?) llvm:pointer-type?)) 59 | (llvm-function-type (->* (llvm:type?) (#:varargs boolean?) #:rest (listof llvm:type?) llvm:function-type?)) 60 | (llvm-function-type* (->* (llvm:type?) (#:varargs boolean?) #:rest (list*/c llvm:type?) llvm:function-type?)) 61 | (llvm-void-type (->* () (#:context llvm:context?) llvm:void-type?)) 62 | 63 | 64 | 65 | ;Predicates 66 | (llvm:integer-type? predicate/c) 67 | (llvm:float-type? predicate/c) 68 | (llvm:function-type? predicate/c) 69 | (llvm:struct-type? predicate/c) 70 | (llvm:unnamed-struct-type? predicate/c) 71 | (llvm:named-struct-type? predicate/c) 72 | (llvm:unset-named-struct-type? predicate/c) 73 | (llvm:array-type? predicate/c) 74 | (llvm:vector-type? predicate/c) 75 | (llvm:pointer-type? predicate/c) 76 | (llvm:void-type? predicate/c) 77 | ;TODO rename to llvm-integer-type-width, etc 78 | (llvm-get-int-type-width 79 | (-> llvm:integer-type? exact-positive-integer?)) 80 | (llvm-get-array-type-length 81 | (-> llvm:array-type? exact-nonnegative-integer?)) 82 | (llvm-get-vector-type-size 83 | (-> llvm:vector-type? exact-positive-integer?)) 84 | 85 | 86 | 87 | 88 | )) 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | ;Deconstructors 99 | 100 | 101 | 102 | 103 | (define (llvm-get-return-type type) 104 | (LLVMGetReturnType type)) 105 | 106 | (define (llvm-get-element-type type) 107 | (LLVMGetElementType type)) 108 | 109 | 110 | 111 | (define (llvm-get-int-type-width type) 112 | (LLVMGetIntTypeWidth type)) 113 | 114 | (define (llvm-get-array-type-length type) 115 | (LLVMGetArrayLength type)) 116 | 117 | (define (llvm-get-vector-type-size type) 118 | (LLVMGetVectorSize type)) 119 | 120 | 121 | 122 | 123 | 124 | ;Constructors 125 | (define (llvm-array-type type (size 0)) 126 | (LLVMArrayType type size)) 127 | 128 | (define (llvm-vector-type type size) 129 | (LLVMVectorType type size)) 130 | 131 | 132 | (define (llvm-struct-type #:context (context (current-context)) #:packed (packed #f) . types) 133 | (LLVMStructTypeInContext context types packed)) 134 | 135 | (define (llvm-struct-type* #:context (context (current-context)) #:packed (packed #f) . types) 136 | (LLVMStructTypeInContext context (apply list* types) packed)) 137 | 138 | (define (llvm-named-struct-type (name "") #:context (context (current-context))) 139 | (LLVMStructCreateNamed context name)) 140 | 141 | (define (llvm-pointer-type type #:address-space (space 0)) 142 | (LLVMPointerType type space)) 143 | 144 | (define (llvm-function-type return-type #:varargs (varargs #f) . args) 145 | (LLVMFunctionType return-type args varargs)) 146 | 147 | (define (llvm-function-type* return-type #:varargs (varargs #f) . args) 148 | (LLVMFunctionType return-type (apply list* args) varargs)) 149 | 150 | 151 | (define (llvm-void-type #:context (context (current-context))) 152 | (LLVMVoidTypeInContext context)) 153 | 154 | 155 | 156 | (define (llvm-int-type) 157 | (current-integer-type)) 158 | 159 | (define (llvm-int1-type #:context (context (current-context))) 160 | (LLVMInt1TypeInContext context)) 161 | 162 | (define (llvm-int8-type #:context (context (current-context))) 163 | (LLVMInt8TypeInContext context)) 164 | 165 | (define (llvm-int16-type #:context (context (current-context))) 166 | (LLVMInt16TypeInContext context)) 167 | 168 | (define (llvm-int32-type #:context (context (current-context))) 169 | (LLVMInt32TypeInContext context)) 170 | 171 | (define (llvm-int64-type #:context (context (current-context))) 172 | (LLVMInt64TypeInContext context)) 173 | 174 | 175 | (define (llvm-single-type #:context (context (current-context))) 176 | (LLVMFloatTypeInContext context)) 177 | 178 | (define (llvm-double-type #:context (context (current-context))) 179 | (LLVMDoubleTypeInContext context)) 180 | 181 | (define (llvm-fp128-type #:context (context (current-context))) 182 | (LLVMFP128TypeInContext context)) 183 | 184 | (define (llvm-x86-fp80-type #:context (context (current-context))) 185 | (LLVMX86FP80TypeInContext context)) 186 | 187 | (define (llvm-ppc-fp128-type #:context (context (current-context))) 188 | (LLVMPPCFP128TypeInContext context)) 189 | 190 | 191 | 192 | ;Mutators 193 | (define (llvm-named-struct-type-set-body! #:packed (packed #f) 194 | type . types) 195 | (LLVMStructSetBody type types packed)) 196 | 197 | (define (llvm-named-struct-type-set-body*! #:packed (packed #f) 198 | type . types) 199 | (LLVMStructSetBody type (apply list* types) packed)) 200 | 201 | 202 | 203 | ;Predicates 204 | 205 | 206 | (define (llvm:function-type? type) 207 | (and (llvm:type? type) 208 | (eq? (llvm-get-type-kind type) 209 | 'LLVMFunctionTypeKind))) 210 | 211 | (define (llvm:composite-type? type) 212 | (and (llvm:type? type) 213 | (memq (llvm-get-type-kind type) 214 | '(LLVMStructTypeKind 215 | LLVMArrayTypeKind 216 | LLVMPointerTypeKind 217 | LLVMVectorTypeKind)))) 218 | 219 | (define (llvm:sequential-type? type) 220 | (and (llvm:type? type) 221 | (memq (llvm-get-type-kind type) 222 | '(LLVMArrayTypeKind 223 | LLVMPointerTypeKind 224 | LLVMVectorTypeKind)))) 225 | 226 | 227 | ;TODO implement 228 | (define (llvm:vector-type? t) #t) 229 | (define (llvm:pointer-type? t) #t) 230 | (define (llvm:void-type? t) #t) 231 | 232 | 233 | (define (llvm:struct-type? type) 234 | (equal? 'LLVMStructTypeKind (llvm-get-type-kind type))) 235 | (define (llvm:unnamed-struct-type? t) #t) 236 | (define (llvm:named-struct-type? t) #t) 237 | (define (llvm:unset-named-struct-type? t) #t) 238 | (define (llvm:array-type? type) 239 | (equal? 'LLVMArrayTypeKind (llvm-get-type-kind type))) 240 | 241 | 242 | -------------------------------------------------------------------------------- /private/simple/util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/contract 5 | unstable/contract) 6 | (provide 7 | (contract-out 8 | (list*/c (-> contract? contract?)) 9 | (non-empty-list*/c (-> contract? contract?)) 10 | (power-of-two? predicate/c))) 11 | 12 | (define (list*/c ctc) 13 | (cond 14 | ((flat-contract? ctc) 15 | (flat-rec-contract rec 16 | (cons/c ctc rec) 17 | (list/c (listof ctc)))) 18 | ((chaperone-contract? ctc) 19 | (define rec 20 | (recursive-contract 21 | (or/c (cons/c ctc rec) 22 | (cons/c (listof ctc) null)) 23 | #:chaperone)) 24 | rec) 25 | (else 26 | (define rec 27 | (recursive-contract 28 | (or/c (cons/c ctc rec) 29 | (cons/c (listof ctc) null)))) 30 | rec))) 31 | 32 | 33 | 34 | (define (non-empty-list*/c ctc) 35 | (or/c 36 | (cons/c ctc (list*/c ctc)) 37 | (list/c (non-empty-listof ctc)))) 38 | 39 | (define (power-of-two? v) 40 | (and (exact-positive-integer? v) 41 | (let loop ((w 1)) 42 | (if (>= w v) 43 | (= w v) 44 | (loop (* 2 w)))))) 45 | -------------------------------------------------------------------------------- /private/simple/values.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | racket/contract 5 | unstable/contract 6 | "predicates.rkt" 7 | "../ffi/safe.rkt") 8 | 9 | (provide 10 | (contract-out 11 | (llvm-terminator-instruction? (-> llvm:value? boolean?)) 12 | (llvm-get-undef (-> llvm:type? llvm:value?)) 13 | (llvm-null (-> llvm:type? llvm:value?)) 14 | (llvm:constant? predicate/c) 15 | (llvm-set-value-name (-> llvm:value? string? void?)) )) 16 | 17 | 18 | 19 | 20 | (define (llvm-terminator-instruction? value) 21 | (LLVMIsTerminatorInstruction value)) 22 | 23 | (define (llvm:constant? value) 24 | (and (llvm:value? value) 25 | (LLVMIsConstant value))) 26 | 27 | 28 | (define (llvm-get-undef type) 29 | (LLVMGetUndef type)) 30 | 31 | (define (llvm-null type) 32 | (LLVMConstNull type)) 33 | 34 | (define (llvm-set-value-name value name) 35 | (LLVMSetValueName value name)) 36 | 37 | 38 | 39 | -------------------------------------------------------------------------------- /private/unsafe/structs.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../ffi/ctypes.rkt") 3 | (provide (rename-out 4 | (unsafe:llvm-value-ref? llvm-value-ref?) 5 | (unsafe:llvm-type-ref? llvm-type-ref?) 6 | (unsafe:llvm-module-ref? llvm-module-ref?) 7 | (unsafe:llvm-context-ref? llvm-context-ref?) 8 | (unsafe:llvm-basic-block-ref? llvm-basic-block-ref?) 9 | (unsafe:llvm-builder-ref? llvm-builder-ref?))) 10 | 11 | 12 | -------------------------------------------------------------------------------- /safe.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "private/ffi/safe.rkt") 3 | (require "private/safe/structs.rkt") 4 | 5 | (provide 6 | (all-from-out 7 | "private/ffi/safe.rkt" 8 | "private/safe/structs.rkt")) 9 | 10 | -------------------------------------------------------------------------------- /simple.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "private/simple/all.rkt") 3 | (require "private/safe/structs.rkt") 4 | 5 | (provide 6 | (all-from-out 7 | "private/simple/all.rkt" 8 | "private/safe/structs.rkt")) 9 | 10 | -------------------------------------------------------------------------------- /tests/tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require 3 | "../simple.rkt" 4 | "../private/short.rkt") 5 | 6 | 7 | (ll 8 | (llvm-define-module module 9 | #:exports (add-float add-byte max-byte) 10 | 11 | 12 | (llvm-define-function add-float 13 | ((left float) (right float) -> float) 14 | (return (+ left right))) 15 | 16 | (llvm-define-function add-byte 17 | ((left i8) (right i8) -> i8) 18 | (return (+ left right))) 19 | 20 | (llvm-define-function max-byte 21 | ((left i8) (right i8) -> i8) 22 | (return 23 | (llvm-if (< left right) 24 | right 25 | left))) 26 | 27 | 28 | )) 29 | 30 | 31 | (llvm-assert-module-valid module) 32 | (void (llvm:optimize-module module)) 33 | (define jit (llvm:create-jit module)) 34 | 35 | 36 | 37 | (define add-float* (llvm:extract-function jit add-float)) 38 | (define add-byte* (llvm:extract-function jit add-byte)) 39 | (define max-byte* (llvm:extract-function jit max-byte)) 40 | 41 | 42 | (llvm:generic->double (add-float* (llvm:double->generic 1) (llvm:double->generic 2))) 43 | (llvm:generic->int (add-byte* (llvm:int8->generic 10) (llvm:int8->generic 3))) 44 | (llvm:generic->int (max-byte* (llvm:int8->generic 3) (llvm:int8->generic 10))) 45 | -------------------------------------------------------------------------------- /unsafe.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "private/ffi/unsafe.rkt") 3 | (require "private/unsafe/structs.rkt") 4 | 5 | (provide 6 | (all-from-out 7 | "private/ffi/unsafe.rkt" 8 | "private/unsafe/structs.rkt")) 9 | 10 | --------------------------------------------------------------------------------