Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Lots of changes and cleanup, moving to define-llvm

  • Loading branch information...
commit 19889f39c041271ffec731f2c441d32952021762 1 parent 632ca46
@endobson authored
View
177 examples/compiler.rkt
@@ -0,0 +1,177 @@
+#lang racket
+
+;Definitions
+;Our language will be simple with two first class data types:
+;Booleans and Integers (32Bit)
+;There will also be first order functions
+;
+;The following expressions will be supported
+;#t, #f, N where N is a numeric literal
+;(if B T F)
+;(binop X Y), where binop ∈ {+,-,x,/,%}
+;(compare X Y), where compare ∈ {<,>,<=,>=,=}
+;(let ((x expr) ...) body)
+;(call fun arg-expr ...)
+;
+;A function definition will look like
+;(define (fun-name arg ...) body)
+;
+;A program is something that looks like
+;(program main-function-name
+; function-definition ...)
+;
+; This implementation is not meant to be perfect and error check everything.
+; It requires that the program be well-typed, for the obvious definition of
+; well-typed.
+
+(require "../private/simple/all.rkt")
+
+; Data for an expression
+(struct num-literal (value))
+(struct bool-literal (value))
+(struct identifier (symbol))
+(struct conditional (test true false))
+(struct binary-op (op left right))
+(struct compare-op (op left right))
+(struct binding (name expr))
+(struct bind (bindings body))
+(struct call (function args))
+
+; Data for a funciton definition
+(struct function-definition (name args body))
+
+; Data for a program
+(struct program (main functions))
+
+(define (parse sexp)
+ (define (binary-op-symbol? x)
+ (member x '(+ - * / %)))
+ (define (compare-op-symbol? x)
+ (member x '(< > <= >= =)))
+ (define (parse-program sexp)
+ (match sexp
+ (`(program ,(? symbol? main) ,funs ...)
+ (program main (map parse-function funs)))))
+ (define (parse-function sexp)
+ (match sexp
+ (`(define (,(? symbol? name) ,(? symbol? args) ...) ,body)
+ (function-definition name args (parse-expression body)))))
+ (define (parse-expression sexp)
+ (match sexp
+ ((? exact-integer? n) (num-literal n))
+ ((? boolean? v) (bool-literal v))
+ ((? symbol? v) (identifier v))
+ (`(if ,c ,t ,f) (conditional (parse-expression c)
+ (parse-expression t)
+ (parse-expression f)))
+ (`(,(? binary-op-symbol? op) ,left ,right)
+ (binary-op op (parse-expression left) (parse-expression right)))
+ (`(,(? compare-op-symbol? op) ,left ,right)
+ (compare-op op (parse-expression left) (parse-expression right)))
+ (`(let ((,(? symbol? vars) ,exprs) ...) ,body)
+ (bind (for/list ((v vars) (e exprs)) (binding v (parse-expression e)))
+ (parse-expression body)))
+ (`(call ,(? symbol? name) ,args ...)
+ (call name (map parse-expression args)))))
+
+ (parse-program sexp))
+
+(define (compile program)
+ (define context (llvm-create-context))
+ (define module (llvm-create-module "module" #:context context))
+
+ (enter-module/32 context module
+ (define function-map
+ (for/hash ((function (program-functions program)))
+ (let ((name (function-definition-name function)))
+ (values name
+ (llvm-add-function
+ (llvm-function-type* (llvm-int32-type)
+ (for/list ((arg (function-definition-args function)))
+ (llvm-int32-type)))
+ (symbol->string (function-definition-name function)))))))
+
+ (define (compile-function function)
+ (match function
+ ((function-definition name args body)
+ (define llvm-function (hash-ref function-map name))
+ (llvm-set-position
+ (llvm-add-block-to-function llvm-function #:name "entry"))
+ (define base-env
+ (for/hash ((arg args) (i (in-naturals)))
+ (values arg (llvm-get-param i))))
+ (llvm-ret (compile-expression body base-env)))))
+
+ (define (convert-binary-op op)
+ (case op
+ ((+) llvm-+)
+ ((-) llvm--)
+ ((*) llvm-*)
+ ((/) llvm-/)
+ ((%) llvm-i%)))
+ (define (convert-compare-op op)
+ (case op
+ ((<) llvm-<)
+ ((>) llvm->)
+ ((<=) llvm-<=)
+ ((>=) llvm->=)
+ ((=) llvm-=)))
+
+ (define (compile-expression expr env)
+ (match expr
+ ((num-literal n) (llvm-int n))
+ ((bool-literal b) (llvm-int (if b 1 0)))
+ ((identifier s) (hash-ref env s))
+ ((binary-op op left right)
+ ((convert-binary-op op)
+ (compile-expression left env)
+ (compile-expression right env)))
+ ((compare-op op left right)
+ ((convert-compare-op op)
+ (compile-expression left env)
+ (compile-expression right env)))
+ ((conditional c t f)
+ (llvm-if (llvm-/= 0 (compile-expression c env))
+ (compile-expression t env)
+ (compile-expression f env)))
+ ((bind bindings body)
+ (let ((new-env (for/fold ((new-env env)) ((binding bindings))
+ (hash-set new-env (binding-name binding)
+ (compile-expression (binding-expr binding))))))
+ (compile-expression body new-env)))
+ ((call name args)
+ (define function (hash-ref function-map name))
+ (define evaled-args
+ (for/list ((arg args)) (compile-expression arg env)))
+ (llvm-call* function evaled-args))))
+
+ (for ((function (program-functions program)))
+ (compile-function function))
+ module))
+
+
+
+(define program1
+ '(program main
+ (define (main) 2)))
+(define program2
+ '(program main
+ (define (main) (if #t 1 2))))
+(define program3
+ '(program main
+ (define (main) (+ (call sub #t) (call sub #f)))
+ (define (sub v) (if v 2 (* 3 (call sub #t))))))
+
+(define program4
+ '(program main
+ (define (main) (call fact 5))
+ (define (fact x)
+ (if (= x 0) 1 (* x (call fact (- x 1)))))))
+
+(compile (parse program1))
+(compile (parse program2))
+(compile (parse program3))
+(compile (parse program4))
+
+
+
View
51 examples/test.rkt
@@ -1,51 +0,0 @@
-#lang racket/base
-
-(require ffi/unsafe)
-(require "../simple.rkt")
-(require "../safe.rkt")
-(require "../private/simple/base.rkt")
-(require "../private/ffi/lib.rkt")
-(require "../private/ffi/ctypes.rkt")
-
-(define context (llvm-create-context))
-(current-context context)
-(define module (llvm-create-module "mandlebrot"))
-(current-module module)
-(current-integer-type (llvm-int32-type))
-(current-float-type (llvm-double-type))
-(current-builder (llvm-create-builder))
-
-(define int-type (llvm-int-type))
-(define bool-type (llvm-int1-type))
-(define float-type (current-float-type))
-
-
-
-(define mandlebrot-type
- (llvm-function-type
- float-type))
-
-(define test-proc
- (_cprocedure (list safe:LLVMTypeRef _double*) _void))
-
-((get-ffi-obj 'LLVMTest llvm-racket-lib test-proc)
- float-type
- 0.0)
-
-(define mandlebrot (llvm-add-function mandlebrot-type "mandlebrot"))
-
-(let ()
- (define entry-block (llvm-add-block-to-function mandlebrot #:name "entry"))
- (llvm-set-position entry-block)
- (llvm-ret 2.0))
-
-
-(let ((err (llvm-verify-module module)))
- (void
- (and err
- (error 'mandlebrot "Bad module: ~a, module" err))))
-
-;(display (llvm-module-description module))
-
-
-
View
3  info.rkt
@@ -1,4 +1,5 @@
#lang setup/infotab
(define name "llvm")
-(define primary-file "llvm.rkt")
+(define primary-file "safe.rkt")
(define categories '(devtools))
+(define scribblings '(("llvm.scrbl" ())))
View
20 llvm.scrbl
@@ -0,0 +1,20 @@
+#lang scribble/manual
+
+@title{LLVM}
+
+This is the start of the documentation for the Racket bindings to the LLVM API.
+
+There are currently two version of the API; Safe and Unsafe. Through the Safe API
+all memory managment of the LLVM objects and does not allow improper use of the API.
+The Unsafe API puts memory management in the users hands and may not catch all
+improper uses of the API. This may lead to corrupted memory or segfaults;
+You have been warnedis done.
+
+On top of the safe API is the Simple API. The Safe API is just a wrapper around
+the C API that checks for correct usage, the Simple API on the other hand does
+conversions and is intended to be more Racket-like.
+
+
+@section{Simple}
+
+The
View
115 private/ffi/arithmetic.rkt
@@ -3,15 +3,11 @@
(require
"enums.rkt"
"define.rkt"
+ "misc-operations.rkt"
"ctypes.rkt")
(require ffi/unsafe)
-(provide
- (except-out (all-defined-out)
- safe:binop
- safe:uniop
- safe:icmp))
;TODO differentiate types and ensure that types match,
;and contexts match
@@ -23,6 +19,27 @@
(ptr : _pointer) ->
(safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder))))
+(define (safe:llvm-value-for-builder/c builder)
+ (and/c
+ safe:llvm-value-ref?
+ (lambda (v)
+ (let ((owner (safe:llvm-value-ref-owner v)))
+ (if (safe:llvm-module-ref? owner)
+ (equal? owner (safe:llvm-builder-ref-module builder))
+ (equal? owner (safe:llvm-module-ref-context
+ (safe:llvm-builder-ref-module builder))))))))
+
+
+(define safe:binop/c
+ (->i ((builder safe:llvm-builder-ref?)
+ (left-value (builder) (safe:llvm-value-for-builder/c builder))
+ (right-value (builder) (safe:llvm-value-for-builder/c builder))
+ (name string?))
+ #:pre/name (left-value right-value) "Values of different types"
+ (equal? (safe:LLVMTypeOf left-value)
+ (safe:LLVMTypeOf right-value))
+ (result safe:llvm-value-ref?)))
+
(define safe:uniop
(_fun (builder : safe:LLVMBuilderRef)
safe:LLVMValueRef
@@ -39,6 +56,18 @@
(ptr : _pointer) ->
(safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder))))
+(define safe:icmp/c
+ (->i ((builder safe:llvm-builder-ref?)
+ (predicate LLVMIntPredicate?)
+ (left-value (builder) (safe:llvm-value-for-builder/c builder))
+ (right-value (builder) (safe:llvm-value-for-builder/c builder))
+ (name string?))
+ #:pre/name (left-value right-value) "Values of different types"
+ (equal? (safe:LLVMTypeOf left-value)
+ (safe:LLVMTypeOf right-value))
+ (result safe:llvm-value-ref?)))
+
+
(define safe:fcmp
(_fun (builder : safe:LLVMBuilderRef)
LLVMRealPredicate
@@ -48,43 +77,26 @@
(ptr : _pointer) ->
(safe:llvm-value-ref ptr (safe:llvm-builder-ref-module builder))))
+(define safe:fcmp/c
+ (->i ((builder safe:llvm-builder-ref?)
+ (predicate LLVMRealPredicate?)
+ (left-value (builder) (safe:llvm-value-for-builder/c builder))
+ (right-value (builder) (safe:llvm-value-for-builder/c builder))
+ (name string?))
+ #:pre/name (left-value right-value) "Values of different types"
+ (equal? (safe:LLVMTypeOf left-value)
+ (safe:LLVMTypeOf right-value))
+ (result safe:llvm-value-ref?)))
-;/* Arithmetic */
-(define-llvm-multiple-unsafe
- (LLVMBuildAdd
- LLVMBuildNSWAdd
- LLVMBuildNUWAdd
- LLVMBuildFAdd
- LLVMBuildSub
- LLVMBuildNSWSub
- LLVMBuildNUWSub
- LLVMBuildFSub
- LLVMBuildMul
- LLVMBuildNSWMul
- LLVMBuildNUWMul
- LLVMBuildFMul
- LLVMBuildUDiv
- LLVMBuildSDiv
- LLVMBuildExactSDiv
- LLVMBuildFDiv
- LLVMBuildURem
- LLVMBuildSRem
- LLVMBuildFRem
- LLVMBuildShl
- LLVMBuildLShr
- LLVMBuildAShr
- LLVMBuildAnd
- LLVMBuildOr
- LLVMBuildXor)
- (_fun LLVMBuilderRef LLVMValueRef LLVMValueRef _string -> LLVMValueRef))
-(define-llvm-multiple-safe
+;/* Arithmetic */
+(define-llvm-multiple
(LLVMBuildAdd
LLVMBuildNSWAdd
LLVMBuildNUWAdd
@@ -110,47 +122,46 @@
LLVMBuildAnd
LLVMBuildOr
LLVMBuildXor)
- safe:binop)
+ #:unsafe (_fun LLVMBuilderRef LLVMValueRef LLVMValueRef _string -> LLVMValueRef)
+ #:safe safe:binop
+ (#:provide (#:safe safe:binop/c)))
+
(define-llvm-unsafe LLVMBuildBinOp
(_fun LLVMBuilderRef LLVMOpcode LLVMValueRef LLVMValueRef _string -> LLVMValueRef))
-(define-llvm-multiple-unsafe
+(define-llvm-multiple
(LLVMBuildNeg
LLVMBuildNSWNeg
LLVMBuildNUWNeg
LLVMBuildFNeg
LLVMBuildNot)
- (_fun LLVMBuilderRef LLVMValueRef _string -> LLVMValueRef))
+ #:unsafe (_fun LLVMBuilderRef LLVMValueRef _string -> LLVMValueRef)
+ #:safe safe:uniop)
-(define-llvm-multiple-safe
- (LLVMBuildNeg
- LLVMBuildNSWNeg
- LLVMBuildNUWNeg
- LLVMBuildFNeg
- LLVMBuildNot)
- safe:uniop)
-
;/* Comparisons */
-(define-llvm-unsafe LLVMBuildICmp
+(define-llvm LLVMBuildICmp
+ #:unsafe
(_fun LLVMBuilderRef
LLVMIntPredicate
LLVMValueRef
LLVMValueRef
- _string -> LLVMValueRef))
+ _string -> LLVMValueRef)
+ #:safe safe:icmp
+ (#:provide (#:safe safe:icmp/c)))
-(define-llvm-safe LLVMBuildICmp safe:icmp)
-(define-llvm-unsafe LLVMBuildFCmp
+(define-llvm LLVMBuildFCmp
+ #:unsafe
(_fun LLVMBuilderRef
LLVMRealPredicate
LLVMValueRef
LLVMValueRef
- _string -> LLVMValueRef))
-
-(define-llvm-safe LLVMBuildFCmp safe:fcmp)
+ _string -> LLVMValueRef)
+ #:safe safe:fcmp
+ (#:provide (#:safe safe:fcmp/c)))
View
92 private/ffi/ctypes.rkt
@@ -1,7 +1,7 @@
#lang racket/base
(require (for-syntax "../llvm-util-exptime.rkt" racket/base syntax/parse))
-(require ffi/unsafe)
+(require ffi/unsafe racket/stxparam)
(require (prefix-in c: racket/contract))
(require "define.rkt")
@@ -9,7 +9,6 @@
(provide
LLVMBool
LLVMContextRef
- unsafe:LLVMContextRef
LLVMModuleRef
LLVMTypeRef
LLVMValueRef
@@ -75,14 +74,6 @@
-(define llvm-will-executor (make-will-executor))
-(void (thread (lambda ()
- (let loop ()
- (will-execute llvm-will-executor)
- (loop)))))
-
-
-
(define LLVMBool _bool)
@@ -205,13 +196,6 @@
...))))
-(define-syntax (make-types stx)
- (syntax-parse stx
- ((_ name:id ...)
- (with-syntax (((unsafe-id ...) (map (lambda (id) (id-prefix 'unsafe: id))
- (syntax->list #'(name ...)))))
- #'(begin
- (define name unsafe-id) ...)))))
@@ -232,23 +216,6 @@
(unsafe:LLVMGenericValueRef unsafe:llvm-generic-value-ref unsafe:llvm-generic-value-ref-pointer)
(safe:LLVMContextRef safe:llvm-context-ref safe:llvm-context-ref-pointer))
-(make-types
- LLVMContextRef
- LLVMModuleRef
- LLVMTypeRef
- LLVMValueRef
- LLVMBasicBlockRef
- LLVMBuilderRef
- LLVMModuleProviderRef
- LLVMMemoryBufferRef
- LLVMPassManagerRef
- LLVMPassRegistryRef
- LLVMUseRef
- LLVMTargetDataRef
- LLVMGenericValueRef
- LLVMExecutionEngineRef)
-
-
(make-safe-llvm-types
(safe:LLVMModuleRef safe:llvm-module-ref safe:llvm-module-ref-pointer)
@@ -259,6 +226,34 @@
(safe:LLVMBuilderRef safe:llvm-builder-ref safe:llvm-builder-ref-pointer)
(safe:LLVMExecutionEngineRef safe:llvm-execution-engine-ref safe:llvm-execution-engine-ref-pointer))
+(define-syntax (make-types stx)
+ (syntax-parse stx
+ ((_ name:id ...)
+ (with-syntax (((unsafe-id ...) (map (lambda (id) (id-prefix 'unsafe: id))
+ (syntax->list #'(name ...)))))
+ #'(begin
+ (define name unsafe-id) ...)))))
+
+(define-syntax define-simple-llvm-safety-parameters
+ (syntax-parser
+ ((_ name:id ...)
+ (with-syntax (((unsafe-id ...) (map (lambda (id) (id-prefix 'unsafe: id))
+ (syntax->list #'(name ...))))
+ ((safe-id ...) (map (lambda (id) (id-prefix 'safe: id))
+ (syntax->list #'(name ...)))))
+ #'(begin
+ (define-llvm-safety-parameter name #:safe safe-id #:unsafe unsafe-id) ...)))))
+
+
+;TODO Remove old uses, and switch to new unsafe: prefixed versions
+(make-types
+ LLVMModuleProviderRef
+ LLVMPassManagerRef
+ LLVMPassRegistryRef
+ LLVMUseRef
+ LLVMTargetDataRef)
+
+
(define safe:LLVMGenericValueRef
(let ()
(define-llvm-safe LLVMDisposeGenericValue (_fun _pointer -> _void))
@@ -266,10 +261,21 @@
safe:llvm-generic-value-ref-pointer
(lambda (ptr)
(let ((v (safe:llvm-generic-value-ref ptr)))
- (will-register llvm-will-executor v
- (lambda (v) (safe:LLVMDisposeGenericValue (safe:llvm-generic-value-ref-pointer v))))
+ (register-finalizer v (lambda (v) (safe:LLVMDisposeGenericValue (safe:llvm-generic-value-ref-pointer v))))
v)))))
+(define-simple-llvm-safety-parameters
+ LLVMContextRef
+ LLVMModuleRef
+ LLVMTypeRef
+ LLVMValueRef
+ LLVMBasicBlockRef
+ LLVMBuilderRef
+ LLVMMemoryBufferRef
+ LLVMGenericValueRef
+ LLVMExecutionEngineRef)
+
+
(define (make-byte-string ptr)
(let loop ((i 0))
@@ -325,7 +331,7 @@
(_fun _string (context : safe:LLVMContextRef)
-> (ptr : _pointer)
-> (let ((mod (safe:llvm-module-ref ptr context)))
- (will-register llvm-will-executor mod safe:LLVMDisposeModule)
+ (register-finalizer mod safe:LLVMDisposeModule)
mod))
(_fun (context buffer) ::
(context : safe:LLVMContextRef)
@@ -337,7 +343,7 @@
->
(if err message
(let ((mod (safe:llvm-module-ref module-ptr context)))
- (will-register llvm-will-executor mod safe:LLVMDisposeModule)
+ (register-finalizer mod safe:LLVMDisposeModule)
mod))))))
@@ -347,7 +353,7 @@
(define-llvm-safe LLVMContextDispose (_fun safe:LLVMContextRef -> _void))
(_fun -> (v : safe:LLVMContextRef)
-> (begin
- (will-register llvm-will-executor v safe:LLVMContextDispose)
+ (register-finalizer v safe:LLVMContextDispose)
v))))
(define safe:LLVMBuilderCreator
@@ -356,7 +362,7 @@
(_fun (context : safe:LLVMContextRef)
-> (ptr : _pointer)
-> (let ((build (safe:llvm-builder-ref ptr context #f)))
- (will-register llvm-will-executor build safe:LLVMDisposeBuilder)
+ (register-finalizer build safe:LLVMDisposeBuilder)
build))))
(define safe:LLVMMemoryBufferCreatorFromFile
@@ -372,7 +378,7 @@
->
(if ans message
(let ((buffer (safe:llvm-memory-buffer-ref buffer-ptr)))
- (will-register llvm-will-executor buffer safe:LLVMDisposeMemoryBuffer)
+ (register-finalizer buffer safe:LLVMDisposeMemoryBuffer)
buffer)))))
(define safe:LLVMExecutionEngineCreator
@@ -407,7 +413,7 @@
->
(if err message
(let ((execution-engine (safe:llvm-execution-engine-ref execution-ptr (list module))))
- (will-register llvm-will-executor execution-engine engine-disposer)
+ (register-finalizer execution-engine engine-disposer)
execution-engine)))))
(define safe:LLVMJITCreator
@@ -443,7 +449,7 @@
->
(if err message
(let ((execution-engine (safe:llvm-execution-engine-ref execution-ptr (list module))))
- (will-register llvm-will-executor execution-engine engine-disposer)
+ (register-finalizer execution-engine engine-disposer)
execution-engine)))))
View
153 private/ffi/define.rkt
@@ -1,6 +1,9 @@
#lang racket
(require typed/racket
+ syntax/parse/define
+ racket/stxparam
+ racket/splicing
(for-syntax "../llvm-util-exptime.rkt" syntax/parse)
(only-in ffi/unsafe get-ffi-obj)
@@ -8,12 +11,16 @@
(provide
+ define-llvm
+ define-llvm-multiple
define-llvm-safe
define-llvm-racket-safe
define-llvm-multiple-safe
define-llvm-unsafe
define-llvm-racket-unsafe
- define-llvm-multiple-unsafe)
+ define-llvm-multiple-unsafe
+ define-llvm-safety-parameter
+ with-llvm-safety)
@@ -29,50 +36,136 @@
-(define-ffi-definer define-llvm-raw llvm-lib)
-(define-ffi-definer define-llvm-racket-raw llvm-racket-lib)
+(define-syntax-parameter llvm-safety #f)
+
+(define-syntax define-llvm-safety-parameter
+ (syntax-parser
+ ((_ name:id body:expr)
+ #'(define-llvm-safety-parameter #:safe body #:unsafe body))
+ ((_ name:id (~seq (~or (~once (~seq #:safe safe-expr:expr))
+ (~once (~seq #:unsafe unsafe-expr:expr))) ...))
+ #'(begin
+ (define safe-id (with-llvm-safety #:safe safe-expr))
+ (define unsafe-id (with-llvm-safety #:unsafe unsafe-expr))
+ (define-syntax (name stx)
+ (let ()
+ (define (get-id)
+ (let ((val (syntax-parameter-value #'llvm-safety)))
+ (case val
+ ((#f) (raise-syntax-error 'llvm-safety "llvm-safety has not been set in this scope" stx))
+ ((unsafe) #'unsafe-id)
+ ((safe) #'safe-id)
+ (else (error 'llvm-safety "Bad value for llvm-safety: ~s" val)))))
+ (...
+ (syntax-parse stx
+ ((_ a ...) #'(#,(get-id) a ...))
+ (_ (get-id))))))))))
+(define-syntax with-llvm-safety
+ (syntax-parser
+ ((_ #:both body:expr ...)
+ #'(values (with-llvm-safety #:safe body ...) (with-llvm-safety #:unsafe body ...)))
+ ((_ (~or (~and #:safe (~bind (safety #''safe)))
+ (~and #:unsafe (~bind (safety #''unsafe))))
+ body:expr ...)
+ #'(syntax-parameterize ((llvm-safety safety))
+ body ...))))
-
-(define-syntaxes (define-llvm-safe define-llvm-racket-safe)
- (let ((definer
- (lambda (define-llvm)
- (syntax-parser
- ((_ name:id type:expr)
- #`(#,define-llvm
- #,(id-prefix 'safe: #'name)
- type
- #:c-id name))))))
- (values
- (definer #'define-llvm-raw)
- (definer #'define-llvm-racket-raw))))
+(define-ffi-definer define-llvm-raw llvm-lib)
+(define-ffi-definer define-llvm-racket-raw llvm-racket-lib)
-(define-syntaxes (define-llvm-unsafe define-llvm-racket-unsafe)
+(define-syntaxes
+ (define-llvm-unsafe
+ define-llvm-racket-unsafe
+ define-llvm-safe
+ define-llvm-racket-safe)
(let ((definer
- (lambda (define-llvm)
+ (lambda (define-llvm safety)
+ (define safety-symbol (if safety 'safe 'unsafe))
(syntax-parser
((_ name:id type:expr)
- #`(#,define-llvm
- #,(id-prefix 'unsafe: #'name)
- type
- #:c-id name))))))
+ (with-syntax ((id (id-prefix safety-symbol (id-prefix ': #'name))))
+ #`(splicing-syntax-parameterize ((llvm-safety '#,safety-symbol))
+ (#,define-llvm id type #:c-id name))))))))
(values
- (definer #'define-llvm-raw)
- (definer #'define-llvm-racket-raw))))
-
-
+ (definer #'define-llvm-raw #f)
+ (definer #'define-llvm-racket-raw #f)
+ (definer #'define-llvm-raw #t)
+ (definer #'define-llvm-racket-raw #t))))
+
+
+
+(begin-for-syntax
+
+ (define (add-safe-prefix id) (id-prefix 'safe: id))
+ (define (add-unsafe-prefix id) (id-prefix 'unsafe: id))
+ (define (null-provide id) #'(begin))
+ (define (simple-provide id) #`(provide #,id))
+ (define ((contracted-provide contract) id)
+ #`(provide (contract-out (#,id #,contract))))
+
+
+ (define-splicing-syntax-class (inner-provide-clause keyword)
+ #:attributes (provide)
+ (pattern (~seq) #:attr provide simple-provide)
+ (pattern (~seq key)
+ #:when (equal? (syntax-e (attribute key)) keyword)
+ #:attr provide simple-provide)
+ (pattern (~seq (key #:no))
+ #:when (equal? (syntax-e (attribute key)) keyword)
+ #:attr provide null-provide)
+ (pattern (~seq (key contract:expr))
+ #:when (equal? (syntax-e (attribute key)) keyword)
+ #:attr provide (contracted-provide #'contract)))
+
+ (define-syntax-class provide-clause
+ #:attributes (safe unsafe)
+ (pattern
+ (#:provide
+ (~seq (~or (~once (~var safe-inner (inner-provide-clause '#:safe)))
+ (~once (~var unsafe-inner (inner-provide-clause '#:unsafe)))) ...))
+ #:attr safe (attribute safe-inner.provide)
+ #:attr unsafe (attribute unsafe-inner.provide)))
+
+ (define-splicing-syntax-class ctype-clause
+ #:attributes (safe unsafe)
+ (pattern (~seq #:both type:expr) #:attr safe #'type #:attr unsafe #'type)
+ (pattern (~seq (~or (~once (~seq #:safe safe:expr)) (~once (~seq #:unsafe unsafe:expr))) ...))))
+
+
+
+(define-syntax define-llvm
+ (syntax-parser
+ ((_ name:id
+ types:ctype-clause
+ (~optional provide:provide-clause
+ #:defaults ((provide.safe simple-provide) (provide.unsafe simple-provide))))
+ (define safe-name (add-safe-prefix #'name))
+ (define unsafe-name (add-unsafe-prefix #'name))
+ #`(begin
+ (define-llvm-safe name types.safe)
+ (define-llvm-unsafe name types.unsafe)
+ #,((attribute provide.safe) safe-name)
+ #,((attribute provide.unsafe) unsafe-name)))))
+
+(define-syntax define-llvm-multiple
+ (syntax-parser
+ ((_ (name:id ...) . rest)
+ #'(begin
+ (define-llvm name . rest) ...))))
+
(define-syntax (define-llvm-multiple-unsafe stx)
- (syntax-case stx ()
- ((_ (name ...) type)
+ (syntax-parse stx
+ ((_ (name:id ...) type:expr)
#'(begin (define-llvm-unsafe name type) ...))))
(define-syntax (define-llvm-multiple-safe stx)
- (syntax-case stx ()
- ((_ (name ...) type)
+ (syntax-parse stx
+ ((_ (name:id ...) type:expr)
#'(begin (define-llvm-safe name type) ...))))
View
8 private/ffi/enums.rkt
@@ -10,9 +10,13 @@
LLVMVisibility
LLVMCallConv
LLVMIntPredicate
+ LLVMIntPredicate?
LLVMRealPredicate
+ LLVMRealPredicate?
LLVMLandingPadClauseTy)
+;;TODO write define-enum that makes a predicate aswell
+
(define << arithmetic-shift)
(define LLVMAttribute (_enum `(
LLVMZExtAttribute = ,(<< 1 0)
@@ -166,6 +170,8 @@
LLVMX86StdcallCallConv = 64
LLVMX86FastcallCallConv = 65)))
+;; TODO make this not such a hack
+(define LLVMIntPredicate? symbol?)
(define LLVMIntPredicate (_enum '(
LLVMIntEQ = 32 ;/**< equal */
LLVMIntNE ;/**< not equal */
@@ -178,6 +184,8 @@
LLVMIntSLT ;/**< signed less than */
LLVMIntSLE))) ;/**< signed less or equal */
+;; TODO make this not such a hack
+(define LLVMRealPredicate? symbol?)
(define LLVMRealPredicate (_enum '(
LLVMRealPredicateFalse ;/**< Always false (always folded) */
LLVMRealOEQ ;/**< True if ordered and equal */
View
32 private/ffi/modules.rkt
@@ -8,23 +8,24 @@
(provide (all-defined-out))
-(define unsafe:LLVMContextCreator (_fun -> unsafe:LLVMContextRef))
;/*===-- Contexts ----------------------------------------------------------===*/
;/* Create and destroy contexts. */
-(define-llvm-unsafe LLVMContextCreate unsafe:LLVMContextCreator)
-(define-llvm-safe LLVMContextCreate safe:LLVMContextCreator)
+(define-llvm LLVMContextCreate
+ #:unsafe (_fun -> LLVMContextRef)
+ #:safe safe:LLVMContextCreator)
-(define-llvm-unsafe LLVMGetGlobalContext (_fun -> unsafe:LLVMContextRef))
-(define-llvm-unsafe LLVMContextDispose (_fun unsafe:LLVMContextRef -> _void))
+(define-llvm-unsafe LLVMGetGlobalContext (_fun -> LLVMContextRef))
+(define-llvm-unsafe LLVMContextDispose (_fun LLVMContextRef -> _void))
+;TODO why have this function
(define (safe:LLVMContextDispose ctx) (void))
-(define-llvm-unsafe LLVMGetMDKindIDInContext (_fun unsafe:LLVMContextRef _string _uint -> _uint))
-(define-llvm-safe LLVMGetMDKindIDInContext (_fun safe:LLVMContextRef _string _uint -> _uint))
+(define-llvm LLVMGetMDKindIDInContext
+ #:both (_fun LLVMContextRef _string _uint -> _uint))
(define-llvm-unsafe LLVMGetMDKindID (_fun _string _uint -> _uint))
@@ -34,13 +35,14 @@
;/* Create and destroy modules. */
;/** See llvm::Module::Module. */
(define-llvm-unsafe LLVMModuleCreateWithName (_fun _string -> LLVMModuleRef))
-(define-llvm-unsafe LLVMModuleCreateWithNameInContext (_fun _string LLVMContextRef -> LLVMModuleRef))
-
-(define-llvm-safe LLVMModuleCreateWithNameInContext safe:LLVMModuleCreator)
+(define-llvm LLVMModuleCreateWithNameInContext
+ #:unsafe (_fun _string LLVMContextRef -> LLVMModuleRef)
+ #:safe safe:LLVMModuleCreator)
;/** See llvm::Module::~Module. */
(define-llvm-unsafe LLVMDisposeModule (_fun LLVMModuleRef -> _void))
+;TODO why have this function
(define (safe:LLVMDisposeModule module) (void))
@@ -49,12 +51,10 @@
(define-llvm-unsafe LLVMSetDataLayout (_fun LLVMModuleRef _string -> _void))
;/** Target triple. See Module::getTargetTriple. */
-(define-llvm-unsafe LLVMGetTarget (_fun LLVMModuleRef -> _string))
-(define-llvm-unsafe LLVMSetTarget (_fun LLVMModuleRef _string -> _void))
-
-(define-llvm-safe LLVMGetTarget (_fun safe:LLVMModuleRef -> _string))
-(define-llvm-safe LLVMSetTarget (_fun safe:LLVMModuleRef _string -> _void))
-
+(define-llvm LLVMGetTarget
+ #:both (_fun LLVMModuleRef -> _string))
+(define-llvm LLVMSetTarget
+ #:both (_fun LLVMModuleRef _string -> _void))
;/** See Module::dump. */
(define-llvm-unsafe LLVMDumpModule (_fun LLVMModuleRef -> _void))
View
5 private/ffi/runtime.rkt
@@ -23,8 +23,9 @@
(_fun _pointer -> LLVMGenericValueRef))
(define (unsafe:LLVMCreateGenericValueOfFunctionType fun-type)
- (get-ffi-obj 'LLVMCreateGenericValueOfPointer llvm-lib
- (_fun fun-type -> LLVMGenericValueRef)))
+ (with-llvm-safety #:unsafe
+ (get-ffi-obj 'LLVMCreateGenericValueOfPointer llvm-lib
+ (_fun fun-type -> LLVMGenericValueRef))))
(define-llvm-unsafe LLVMCreateGenericValueOfFloat
(_fun LLVMTypeRef _double* -> LLVMGenericValueRef))
View
2  private/simple/all.rkt
@@ -10,6 +10,7 @@
"comparison.rkt"
"convertible.rkt"
"extra.rkt"
+ "functions.rkt"
"generic.rkt"
"globals.rkt"
"intrinsics.rkt"
@@ -32,6 +33,7 @@
"comparison.rkt"
"cast.rkt"
"extra.rkt"
+ "functions.rkt"
"generic.rkt"
"globals.rkt"
"intrinsics.rkt"
View
1  private/simple/convertible.rkt
@@ -3,7 +3,6 @@
(require
racket/contract/base
racket/contract/combinator
- unstable/prop-contract
unstable/contract
"../ffi/safe.rkt"
"types.rkt"
Please sign in to comment.
Something went wrong with that request. Please try again.