Coverage report: /home/ellis/.stash/quicklisp/dists/quicklisp/software/cffi-20250622-git/src/cffi-sbcl.lisp

Kind	Covered	All	%
expression	30	232	12.9
branch	0	8	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-

2

;;;

3

;;; cffi-sbcl.lisp --- CFFI-SYS implementation for SBCL.

4

;;;

5

6

;;;

7

;;; Permission is hereby granted, free of charge, to any person

8

;;; obtaining a copy of this software and associated documentation

9

;;; files (the "Software"), to deal in the Software without

10

;;; restriction, including without limitation the rights to use, copy,

11

;;; modify, merge, publish, distribute, sublicense, and/or sell copies

12

;;; of the Software, and to permit persons to whom the Software is

13

;;; furnished to do so, subject to the following conditions:

14

;;;

15

;;; The above copyright notice and this permission notice shall be

16

;;; included in all copies or substantial portions of the Software.

17

;;;

18

;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,

19

;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF

20

;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND

21

;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT

22

;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,

23

;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,

24

;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER

25

;;; DEALINGS IN THE SOFTWARE.

26

;;;

27

28

(in-package #:cffi-sys)

29

30

;;;# Misfeatures

31

32

(pushnew 'flat-namespace *features*)

33

34

;;;# Symbol Case

35

36

(declaim (inline canonicalize-symbol-name-case))

37

(defun canonicalize-symbol-name-case (name)

38

(declare (string name))

39

(string-upcase name))

40

41

;;;# Basic Pointer Operations

42

43

(deftype foreign-pointer ()

44

'sb-sys:system-area-pointer)

45

46

(declaim (inline pointerp))

47

(defun pointerp (ptr)

48

"Return true if PTR is a foreign pointer."

49

(sb-sys:system-area-pointer-p ptr))

50

51

(declaim (inline pointer-eq))

52

(defun pointer-eq (ptr1 ptr2)

53

"Return true if PTR1 and PTR2 point to the same address."

54

(declare (type system-area-pointer ptr1 ptr2))

55

(sb-sys:sap= ptr1 ptr2))

56

57

(declaim (inline null-pointer))

58

(defun null-pointer ()

59

"Construct and return a null pointer."

60

(sb-sys:int-sap 0))

61

62

(declaim (inline null-pointer-p))

63

(defun null-pointer-p (ptr)

64

"Return true if PTR is a null pointer."

65

(declare (type system-area-pointer ptr))

66

(zerop (sb-sys:sap-int ptr)))

67

68

(declaim (inline inc-pointer))

69

(defun inc-pointer (ptr offset)

70

"Return a pointer pointing OFFSET bytes past PTR."

71

(declare (type system-area-pointer ptr)

72

(type integer offset))

73

(sb-sys:sap+ ptr offset))

74

75

(declaim (inline make-pointer))

76

(defun make-pointer (address)

77

"Return a pointer pointing to ADDRESS."

78

;; (declare (type (unsigned-byte 32) address))

79

(sb-sys:int-sap address))

80

81

(declaim (inline pointer-address))

82

(defun pointer-address (ptr)

83

"Return the address pointed to by PTR."

84

(declare (type system-area-pointer ptr))

85

(sb-sys:sap-int ptr))

86

87

;;;# Allocation

88

;;;

89

;;; Functions and macros for allocating foreign memory on the stack

90

;;; and on the heap. The main CFFI package defines macros that wrap

91

;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage

92

;;; when the memory has dynamic extent.

93

94

(declaim (inline %foreign-alloc))

95

(defun %foreign-alloc (size)

96

"Allocate SIZE bytes on the heap and return a pointer."

97

;; (declare (type (unsigned-byte 32) size))

98

(alien-sap (make-alien (unsigned 8) size)))

99

100

(declaim (inline foreign-free))

101

(defun foreign-free (ptr)

102

"Free a PTR allocated by FOREIGN-ALLOC."

103

(declare (type system-area-pointer ptr)

104

(optimize speed))

105

(free-alien (sap-alien ptr (* (unsigned 8)))))

106

107

(defmacro with-foreign-pointer ((var size &optional size-var) &body body)

108

"Bind VAR to SIZE bytes of foreign memory during BODY. The

109

pointer in VAR is invalid beyond the dynamic extent of BODY, and

110

may be stack-allocated if supported by the implementation. If

111

SIZE-VAR is supplied, it will be bound to SIZE during BODY."

112

(unless size-var

113

(setf size-var (gensym "SIZE")))

114

;; If the size is constant we can stack-allocate.

115

(if (constantp size)

116

(let ((alien-var (gensym "ALIEN")))

117

`(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))

118

(let ((,size-var ,(eval size))

119

(,var (alien-sap ,alien-var)))

120

(declare (ignorable ,size-var))

121

,@body)))

122

`(let* ((,size-var ,size)

123

(,var (%foreign-alloc ,size-var)))

124

(unwind-protect

125

(progn ,@body)

126

(foreign-free ,var)))))

127

128

;;;# Shareable Vectors

129

;;;

130

;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA

131

;;; should be defined to perform a copy-in/copy-out if the Lisp

132

;;; implementation can't do this.

133

134

(declaim (inline make-shareable-byte-vector))

135

(defun make-shareable-byte-vector (size)

136

"Create a Lisp vector of SIZE bytes that can be passed to

137

WITH-POINTER-TO-VECTOR-DATA."

138

; (declare (type sb-int:index size))

139

(make-array size :element-type '(unsigned-byte 8)))

140

141

(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)

142

"Bind PTR-VAR to a foreign pointer to the data in VECTOR."

143

(let ((vector-var (gensym "VECTOR")))

144

`(let ((,vector-var ,vector))

145

(declare (type (sb-kernel:simple-unboxed-array (*)) ,vector-var))

146

(sb-sys:with-pinned-objects (,vector-var)

147

(let ((,ptr-var (sb-sys:vector-sap ,vector-var)))

148

,@body)))))

149

150

;;;# Dereferencing

151

152

;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler

153

;;; macros that optimize the case where the type keyword is constant

154

;;; at compile-time.

155

(defmacro define-mem-accessors (&body pairs)

156

`(progn

157

(defun %mem-ref (ptr type &optional (offset 0))

158

(ecase type

159

,@(loop for (keyword fn) in pairs

160

collect `(,keyword (,fn ptr offset)))))

161

(defun %mem-set (value ptr type &optional (offset 0))

162

(ecase type

163

,@(loop for (keyword fn) in pairs

164

collect `(,keyword (setf (,fn ptr offset) value)))))

165

(define-compiler-macro %mem-ref

166

(&whole form ptr type &optional (offset 0))

167

(if (constantp type)

168

(ecase (eval type)

169

,@(loop for (keyword fn) in pairs

170

collect `(,keyword `(,',fn ,ptr ,offset))))

171

form))

172

(define-compiler-macro %mem-set

173

(&whole form value ptr type &optional (offset 0))

174

(if (constantp type)

175

(once-only (value)

176

(ecase (eval type)

177

,@(loop for (keyword fn) in pairs

178

collect `(,keyword `(setf (,',fn ,ptr ,offset)

179

,value)))))

180

form))))

181

182

;;; Look up alien type information and build both define-mem-accessors form

183

;;; and convert-foreign-type function definition.

184

(defmacro define-type-mapping (accessor-table alien-table)

185

(let* ((accessible-types

186

(remove 'void alien-table :key #'second))

187

(size-and-signedp-forms

188

(mapcar (lambda (name)

189

(list (eval `(alien-size ,(second name)))

190

(typep -1 `(alien ,(second name)))))

191

accessible-types)))

192

`(progn

193

(define-mem-accessors

194

,@(loop for (cffi-keyword alien-type fixed-accessor)

195

in accessible-types

196

and (alien-size signedp)

197

in size-and-signedp-forms

198

for (signed-ref unsigned-ref)

199

= (cdr (assoc alien-size accessor-table))

200

collect

201

`(,cffi-keyword

202

,(or fixed-accessor

203

(if signedp signed-ref unsigned-ref)

204

(error "No accessor found for ~S"

205

alien-type)))))

206

(defun convert-foreign-type (type-keyword)

207

(ecase type-keyword

208

,@(loop for (cffi-keyword alien-type) in alien-table

209

collect `(,cffi-keyword (quote ,alien-type))))))))

210

211

(define-type-mapping

212

((8 sb-sys:signed-sap-ref-8 sb-sys:sap-ref-8)

213

(16 sb-sys:signed-sap-ref-16 sb-sys:sap-ref-16)

214

(32 sb-sys:signed-sap-ref-32 sb-sys:sap-ref-32)

215

(64 sb-sys:signed-sap-ref-64 sb-sys:sap-ref-64))

216

((:char char)

217

(:unsigned-char unsigned-char)

218

(:short short)

219

(:unsigned-short unsigned-short)

220

(:int int)

221

(:unsigned-int unsigned-int)

222

(:long long)

223

(:unsigned-long unsigned-long)

224

(:long-long long-long)

225

(:unsigned-long-long unsigned-long-long)

226

(:float single-float

227

sb-sys:sap-ref-single)

228

(:double double-float

229

sb-sys:sap-ref-double)

230

(:pointer system-area-pointer

231

sb-sys:sap-ref-sap)

232

(:void void)))

233

234

;;;# Calling Foreign Functions

235

236

(defun %foreign-type-size (type-keyword)

237

"Return the size in bytes of a foreign type."

238

(/ (sb-alien-internals:alien-type-bits

239

(sb-alien-internals:parse-alien-type

240

(convert-foreign-type type-keyword) nil)) 8))

241

242

(defun %foreign-type-alignment (type-keyword)

243

"Return the alignment in bytes of a foreign type."

244

#+(and darwin ppc (not ppc64))

245

(case type-keyword

246

((:double :long-long :unsigned-long-long)

247

(return-from %foreign-type-alignment 8)))

248

;; No override necessary for other types...

249

(/ (sb-alien-internals:alien-type-alignment

250

(sb-alien-internals:parse-alien-type

251

(convert-foreign-type type-keyword) nil)) 8))

252

253

(defun foreign-funcall-type-and-args (args)

254

"Return an SB-ALIEN function type for ARGS."

255

(let ((return-type 'void)

256

types

257

fargs)

258

(loop while args

259

do (let ((type (pop args)))

260

(cond ((eq type '&optional)

261

(push type types))

262

((not args)

263

(setf return-type (convert-foreign-type type)))

264

(t

265

(push (convert-foreign-type type) types)

266

(push (pop args) fargs)))))

267

(values (nreverse types)

268

(nreverse fargs)

269

return-type)))

270

271

(defmacro %%foreign-funcall (name types fargs rettype)

272

"Internal guts of %FOREIGN-FUNCALL."

273

`(alien-funcall

274

(extern-alien ,name (function ,rettype ,@types))

275

,@fargs))

276

277

(defmacro %foreign-funcall (name args &key library convention)

278

"Perform a foreign function call, document it more later."

279

(declare (ignore library convention))

280

(multiple-value-bind (types fargs rettype)

281

(foreign-funcall-type-and-args args)

282

`(%%foreign-funcall ,name ,types ,fargs ,rettype)))

283

284

(defmacro %foreign-funcall-pointer (ptr args &key convention)

285

"Funcall a pointer to a foreign function."

286

(declare (ignore convention))

287

(multiple-value-bind (types fargs rettype)

288

(foreign-funcall-type-and-args args)

289

(with-unique-names (function)

290

`(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))

291

(alien-funcall ,function ,@fargs)))))

292

293

(defmacro %foreign-funcall-varargs (name fixed-args varargs

294

&rest args &key convention library)

295

(declare (ignore convention library))

296

`(%foreign-funcall ,name ,(append fixed-args (and varargs

297

                                                     ;; All SBCL platforms would understand this

298

                                                     ;; but this is the only one where it's required.

299

                                                     ;; Omitting elsewhere makes it work on older

300

                                                     ;; versions of SBCL.

301

                                                     (append #+(and darwin arm64)

302

                                                             '(&optional)

303

                                                             varargs)))

304

,@args))

305

306

(defmacro %foreign-funcall-pointer-varargs (pointer fixed-args varargs

307

&rest args &key convention)

308

(declare (ignore convention))

309

`(%foreign-funcall-pointer ,pointer ,(append fixed-args

310

(and varargs

311

                                                     (append #+(and darwin arm64)

312

                                                             '(&optional)

313

                                                             varargs)))

314

,@args))

315

316

317

;;;# Callbacks

318

319

(defmacro %defcallback (name rettype arg-names arg-types body

320

&key convention)

321

(check-type convention (member :stdcall :cdecl))

322

`(progn

323

(sb-alien:define-alien-callable ,name

324

(,convention ,(convert-foreign-type rettype))

325

,(mapcar (lambda (sym type)

326

(list sym (convert-foreign-type type)))

327

arg-names arg-types)

328

,body)

329

(%callback ',name)))

330

331

(defun %callback (name)

332

(let ((callback (alien-callable-function name)))

333

(if callback

334

(alien-sap callback)

335

(error "Undefined callback: ~S" name))))

336

337

;;;# Loading and Closing Foreign Libraries

338

339

#+darwin

340

(defun call-within-initial-thread (fn &rest args)

341

(if (eq sb-thread:*current-thread*

342

sb-thread::*initial-thread*)

343

(apply fn args)

344

(let (result

345

error

346

(sem (sb-thread:make-semaphore)))

347

(sb-thread:interrupt-thread

348

sb-thread::*initial-thread*

349

(lambda ()

350

(sb-sys:with-interrupts

351

(multiple-value-setq (result error)

352

(ignore-errors (apply fn args))))

353

(sb-thread:signal-semaphore sem)))

354

(sb-thread:wait-on-semaphore sem)

355

(if error

356

(signal error)

357

result))))

358

359

(declaim (inline %load-foreign-library))

360

(defun %load-foreign-library (name path)

361

"Load a foreign library."

362

(declare (ignore name))

363

;; As of MacOS X 10.6.6, loading things like CoreFoundation from a

364

;; thread other than the initial one results in a crash.

365

#+(and darwin sb-thread) (call-within-initial-thread #'load-shared-object path)

366

#-(and darwin sb-thread) (load-shared-object path))

367

368

;;; SBCL 1.0.21.15 renamed SB-ALIEN::SHARED-OBJECT-FILE but introduced

369

;;; SB-ALIEN:UNLOAD-SHARED-OBJECT which we can use instead.

370

(eval-when (:compile-toplevel :load-toplevel :execute)

371

(defun unload-shared-object-present-p ()

372

(multiple-value-bind (foundp kind)

373

(find-symbol "UNLOAD-SHARED-OBJECT" "SB-ALIEN")

374

(if (and foundp (eq kind :external))

375

'(:and)

376

'(:or)))))

377

378

(defun %close-foreign-library (handle)

379

"Closes a foreign library."

380

#+#.(cffi-sys::unload-shared-object-present-p)

381

(sb-alien:unload-shared-object handle)

382

#-#.(cffi-sys::unload-shared-object-present-p)

383

(sb-thread:with-mutex (sb-alien::*shared-objects-lock*)

384

(let ((obj (find (sb-ext:native-namestring handle)

385

sb-alien::*shared-objects*

386

:key #'sb-alien::shared-object-file

387

:test #'string=)))

388

(when obj

389

(sb-alien::dlclose-or-lose obj)

390

(removef sb-alien::*shared-objects* obj)

391

#-win32

392

(sb-alien::update-linkage-table)))))

393

394

(defun native-namestring (pathname)

395

(sb-ext:native-namestring pathname))

396

397

;;;# Foreign Globals

398

399

(defun %foreign-symbol-pointer (name library)

400

"Returns a pointer to a foreign symbol NAME."

401

(declare (ignore library))

402

(when-let (address (sb-sys:find-foreign-symbol-address name))

403

(sb-sys:int-sap address)))