1  (define-module (llvm target-machine)
  2    #:use-module ((rnrs base) #:select (assert))
  3    #:use-module (system foreign)
  4    #:use-module (oop goops)
  5    #:use-module (llvm types)
  6    #:use-module (llvm context)
  7    #:use-module (llvm module)
  8    #:use-module (llvm raw)
  9    #:use-module (llvm utils)
 10    #:export (create-target-machine))
 11  
 12  (define-inlinable (%target-name target)
 13    (pointer->string
 14     (LLVMGetTargetName target)))
 15  
 16  (define-method (write (o <llvm-target>) file)
 17    (let ((class (class-of o))
 18          (name (slot-ref o 'name)))
 19      (display "#<" file)
 20      (display (class-name class) file)
 21      (display #\space file)
 22      (display name file)
 23      (display #\space file)
 24      (display-address o file)
 25      (display #\> file)))
 26  
 27  (define-public (first-target)
 28    (let ((p (LLVMGetFirstTarget)))
 29      (if (null-pointer? p)
 30          #f
 31          (wrap-llvm-target
 32           p
 33           #:name
 34           (%target-name p)))))
 35  
 36  (define-public (next-target target)
 37    (let ((p (LLVMGetNextTarget (unwrap-llvm-target target))))
 38      (if (null-pointer? p)
 39          #f
 40          (wrap-llvm-target
 41           p
 42           #:name
 43           (%target-name p)))))
 44  
 45  (define-public (target-name target)
 46    (%target-name (unwrap-llvm-target target)))
 47  
 48  (define-public (target-from-triple triple)
 49    (let* ((t-p (make-double-pointer))
 50           (error-p (make-double-pointer))
 51           (success? (LLVMGetTargetFromTriple
 52                      (string->pointer triple)
 53                      t-p error-p)))
 54      (if (zero? success?)
 55          (let ((p (dereference-pointer t-p)))
 56            (if (null-pointer? p)
 57                #f
 58                (wrap-llvm-target p #:name (%target-name p))))
 59          (error 'llvm-error 'target-from-triple (llvm-pointer->string (dereference-pointer error-p))))))
 60  
 61  (define-public (target-from-name name)
 62    (let ((p (LLVMGetTargetFromName (string->pointer name))))
 63      (if (null-pointer? p)
 64          #f
 65          (wrap-llvm-target
 66           p
 67           #:name name))))
 68  (define-public (target-description target)
 69    (pointer->string (LLVMGetTargetDescription (unwrap-llvm-target target))))
 70  
 71  (define-public (has-jit? target)
 72    (let ((p (unwrap-llvm-target target)))
 73      (not (zero? (LLVMTargetHasJIT p)))))
 74  
 75  (define-public (has-target-machine? target)
 76    (let ((p (unwrap-llvm-target target)))
 77      (not (zero? (LLVMTargetHasTargetMachine p)))))
 78  
 79  (define-public (has-asm-backend? target)
 80    (let ((p (unwrap-llvm-target target)))
 81      (not (zero? (LLVMTargetHasAsmBackend p)))))
 82  
 83  (define-public (default-target-triple)
 84    (let ((p (LLVMGetDefaultTargetTriple)))
 85      (llvm-pointer->string p)))
 86  
 87  (define-public (normalize-target-triple str)
 88    (let ((p (LLVMNormalizeTargetTriple (string->pointer str))))
 89      (llvm-pointer->string p)))
 90  (define-public (host-cpu-name)
 91    (let ((p (LLVMGetHostCPUName)))
 92      (llvm-pointer->string p)))
 93  
 94  (define-public (host-cpu-features)
 95    (let ((p (LLVMGetHostCPUFeatures)))
 96      (llvm-pointer->string p)))
 97  
 98  ;;;*===-- Target Machine --------------------------------------------------===*;
 99  
100  ;; (define-public (create-target-machine-options)
101  ;;   (LLVMCreateTargetMachineOptions))
102  ;; (define-public LLVMTargetMachineOptionsSetCPU)
103  
104  (define* (create-target-machine
105            #:key
106            (triple (default-target-triple))
107            (target (target-from-triple triple))
108            (cpu (host-cpu-name))
109            (features (host-cpu-features))
110            (level LLVMCodeGenLevelNone)
111            (reloc LLVMRelocDefault)
112            (code-model LLVMCodeModelDefault))
113    (wrap-llvm-target-machine
114     (LLVMCreateTargetMachine
115      (unwrap-llvm-target target)
116      (string->pointer triple)
117      (string->pointer cpu)
118      (string->pointer features)
119      (case level
120        ((none) LLVMCodeGenLevelNone)
121        ((less) LLVMCodeGenLevelLess)
122        ((default) LLVMCodeGenLevelDefault)
123        ((aggressive) LLVMCodeGenLevelAggressive)
124        (else level))
125      (case reloc
126        ((default) LLVMRelocDefault)
127        ((static) LLVMRelocStatic)
128        ((pic) LLVMRelocPIC)
129        ((dynamic-no-pic) LLVMRelocDynamicNoPic)
130        ((ropi) LLVMRelocROPI)
131        ((rwpi) LLVMRelocRWPI)
132        ((ropi-rwpi) LLVMRelocROPI_RWPI)
133        (else reloc))
134      (case code-model
135        ((default) LLVMCodeModelDefault)
136        ((jit-default) LLVMCodeModelJITDefault)
137        ((tiny) LLVMCodeModelTiny)
138        ((small) LLVMCodeModelSmall)
139        ((kernel) LLVMCodeModelKernel)
140        ((medium) LLVMCodeModelMedium)
141        ((large) LLVMCodeModelLarge)
142        (else code-model)))))
143  
144  (define-public (target-machine-emit tm m file-type)
145    (assert (module-verify m))
146    (let* ((message-pointer (make-double-pointer))
147           (buffer-pointer (make-double-pointer))
148           (ret (LLVMTargetMachineEmitToMemoryBuffer
149                 (unwrap-llvm-target-machine tm)
150                 (unwrap-llvm-module m)
151                 (case file-type
152                   ((assembly) 0)
153                   ((object) 1)
154                   (else file-type))
155                 message-pointer
156                 buffer-pointer
157                 )))
158      (if (zero? ret)
159          (wrap-llvm-memory-buffer (dereference-pointer buffer-pointer))
160          (error 'llvm-error
161                 'target-machine-emit
162                 (llvm-pointer->string
163                  (dereference-pointer message-pointer))))))