1  (define-module (llvm function)
  2    #:use-module ((rnrs base) #:select (assert))
  3    #:use-module (srfi srfi-26)
  4    #:use-module (rnrs bytevectors)
  5    #:use-module (llvm module)
  6    #:use-module (system foreign)
  7    #:use-module ((oop goops) #:select (define-method slot-set! slot-ref class-of class-name
  8                                         change-class))
  9    #:use-module (llvm types)
 10    #:use-module (llvm type)
 11    #:use-module (llvm value)
 12    #:use-module (llvm raw)
 13    #:use-module (llvm utils)
 14    #:export (add-function
 15              add-function*
 16              delete-function
 17              find-function
 18              get-named-function
 19              first-block))
 20  
 21  (define-method (write (o <llvm-function>) file)
 22    (let ((class (class-of o))
 23          (type (slot-ref o 'type))
 24          (name (slot-ref o 'name)))
 25      (display "#<" file)
 26      (display (class-name class) file)
 27      (display #\space file)
 28      (display (type->string (slot-ref type 'return-type)) file)
 29      (display #\space file)
 30      (display #\@ file)
 31      (display name file)
 32      (display #\space file)
 33      (display (map value->string (params o)) file)
 34      (display #\space file)
 35      (display-address o file)
 36      (display #\> file)))
 37  
 38  (define-public (add-function* m name type)
 39    (let* ((p (LLVMAddFunction (unwrap-llvm-module m)
 40                               (string->pointer name)
 41                               (unwrap-llvm-function-type type)))
 42           (o (wrap-llvm-value p #:module m #:type type)))
 43      (slot-set! m 'functions
 44                 (cons
 45                  o
 46                  (slot-ref m 'functions)))
 47      o))
 48  
 49  (define* (add-function m #:key
 50                         (name "")
 51                         (return (void-type))
 52                         (arg-types '())
 53                         (var-arg? #f))
 54    (add-function* m name (function-type
 55                           #:return return
 56                           #:arg-types arg-types
 57                           #:var-arg? var-arg?)))
 58  
 59  (define (delete-function fn)
 60    (let ((fn-p (unwrap-llvm-function fn))
 61          (m (slot-ref fn 'module)))
 62      (slot-set! m 'functions
 63                 (delete
 64                  fn
 65                  (slot-ref m 'functions)))
 66      (slot-set! fn 'module #f)
 67      (LLVMDeleteFunction fn-p)
 68      (change-class fn <llvm-freed>)
 69      *unspecified*))
 70  
 71  (define (get-named-function m name)
 72    (let ((p (LLVMGetNamedFunction
 73              (unwrap-llvm-module m)
 74              (string->pointer name))))
 75      (if (null-pointer? p)
 76          #f
 77          (wrap-llvm-value
 78           p))))
 79  (define find-function get-named-function)
 80  
 81  (define-public (first-function m)
 82    (wrap-llvm-value
 83     (LLVMGetFirstFunction
 84      (unwrap-llvm-module m))))
 85  
 86  (define (get-called-function-type c)
 87    (wrap-llvm-type
 88     (LLVMGetCalledFunctionType
 89      (unwrap-llvm-value c))))
 90  
 91  (define-public (param fn index)
 92    (let* ((fn-p  (unwrap-llvm-value fn))
 93           (count (LLVMCountParams fn-p)))
 94      (assert (< index count))
 95      (wrap-llvm-value
 96       (LLVMGetParam fn-p index)
 97       #:function fn)))
 98  
 99  (define-public (function-set-gc! fn gc)
100    (assert
101     (member gc
102             (list "shadow-stack"
103                   "erlang"
104                   "ocaml"
105                   "statepoint-example"
106                   "coreclr")))
107    (let* ((fn-p (unwrap-llvm-function fn)))
108      (LLVMSetGC fn-p (string->pointer gc))))
109  
110  (define-public (function-get-gc fn)
111    (let* ((fn-p (unwrap-llvm-function fn))
112           (ret (LLVMGetGC fn-p)))
113      (if (null-pointer? ret)
114          #f
115          (pointer->string ret))))
116  
117  (define-public function-gc
118    (make-procedure-with-setter function-get-gc
119                                function-set-gc!))
120  
121  (define-public (params fn)
122    (let* ((fn-p (unwrap-llvm-function fn))
123           (count (LLVMCountParams fn-p))
124           (pa (bytevector->pointer
125                (make-bytevector (* count (sizeof '*))))))
126      (LLVMGetParams fn-p pa)
127      (map (cut wrap-llvm-value <> #:function fn)
128           (parse-c-struct* pa (make-list count '*)))))
129  
130  (define-public (param-types fn)
131    (let* ((fn-p (unwrap-llvm-type fn))
132           (count (LLVMCountParamTypes fn-p)))
133      (if (zero? count)
134          '()
135          (let ((p (bytevector->pointer
136                    (make-bytevector (* count (sizeof '*))))))
137            (LLVMGetParamTypes fn-p p)
138            (map wrap-llvm-type
139                 (parse-c-struct p (make-list count '*)))))))
140  
141  (define (first-block block)
142    (let* ((f-p (unwrap-llvm-function block))
143           (b-p (LLVMGetFirstBasicBlock f-p))
144           (b (wrap-llvm-block b-p)))
145      b))
146