changeset 695: |
2bad47888dbf |
parent: |
5f88b237ce29
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Fri, 04 Oct 2024 16:14:44 -0400 |
permissions: |
-rw-r--r-- |
description: |
add static-vector |
1 ;;; alien.lisp --- foreign alien friends 7 ;; FFI in Lisp is somewhat different than FFI in other host langs. As 8 ;; such, we usually refer to our Lispy FFI interfaces inline with the 9 ;; CMUCL terminology: alien interfaces. 11 ;; ref: https://www.sbcl.org/manual/#Foreign-Function-Interface for details 13 ;; sb-alien is a high-level interface which automatically converts C 14 ;; memory pointers to lisp objects and back, but this can be slow for 15 ;; large or complex objects. 17 ;; The lower-level interface is based on System Area Pointers (or 18 ;; SAPs), which provide untyped access to foreign memory. 20 ;; Objects which can't be automatically converted into Lisp values are 21 ;; represented by objects of type ALIEN-VALUE. 24 (in-package :std/alien) 26 ;; '(sb-unix::syscall sb-unix::syscall* sb-unix::int-syscall 27 ;; sb-unix::with-restarted-syscall sb-unix::void-syscall) :std) 29 ;; (reexport-from :sb-vm 31 ;; '(:with-pinned-objects :with-pinned-object-iterator :with-code-pages-pinned 32 ;; :sanctify-for-execution)) 34 (defun shared-object-name (name &optional path) 35 "Return a filename with the correct extension for a shared library." 36 (let ((name #+darwin (format nil "lib~a.dylib" name) 37 #-darwin (format nil "lib~a.so" name))) 39 (merge-pathnames name path) 42 (defun list-all-shared-objects () 43 sb-alien::*shared-objects*) 45 (defmacro define-alien-loader (name &optional export (root "/usr/local/lib/") path) 46 "Define a default loader function named load-NAME which calls 47 SB-ALIEN:LOAD-SHARED-OBJECT." 48 (let* ((fname (sb-int:symbolicate (format nil "~@:(load-~a~)" name)))) 50 (defun ,fname (&optional save) 51 (prog1 (sb-alien:load-shared-object (shared-object-name ',(or path name) ,root) :dont-save (not save)) 52 (pushnew ,(sb-int:keywordicate (string-upcase name)) *features*))) 53 ,@(when export (list `(export '(,fname))))))) 55 (defmacro define-opaque (ty &optional no-export foreign-type) 57 (eval-when (:compile-toplevel :load-toplevel :execute) 58 (define-alien-type ,ty (struct ,(or foreign-type (symbolicate ty '-t))))) 59 ,(unless no-export `(export '(,ty))))) 61 (defun setfa (place from) 62 (loop for x across from 63 for i from 0 below (length from) 64 do (setf (deref place i) x))) 66 (defun copy-c-string (src dest &aux (index 0)) 67 (declare (type sb-int:index index)) 68 (loop (let ((b (sb-sys:sap-ref-8 src index))) 70 (setf (fill-pointer dest) index) 72 (setf (char dest index) (code-char b)) 75 (defun clone-strings (list) 76 (let ((len (length list))) 77 (with-alien ((x (* (* char)) (make-alien (* char) len))) 78 (labels ((populate (list index) 79 (declare (type sb-int:index index)) 81 (let ((array (sb-ext:string-to-octets (car list) :null-terminate t))) 82 (sb-sys:with-pinned-objects (array) 83 (setf (deref x index) (sap-alien (sb-sys:vector-sap array) (* char))) 84 (populate (cdr list) (1+ index)))) 86 (cast (populate list 0) (* c-string)))))) 88 (defun c-strings-to-string-list (c-strings) 89 (declare (type (alien (* c-string)) c-strings)) 90 (let ((reversed-result nil)) 91 (dotimes (i most-positive-fixnum) 92 (declare (type sb-int:index i)) 93 (let ((c-string (deref c-strings i))) 95 (push c-string reversed-result) 96 (return (nreverse reversed-result))))))) 98 (defun clone-octets-to-alien (lispa alien) 99 (declare (optimize (speed 3)) 100 ((vector (unsigned-byte 8)) lispa)) 101 ;; (setf aliena (cast aliena (array (unsigned 8)))) 102 (loop for i from 0 below (length lispa) 103 do (setf (deref alien i) 107 (defun octets-to-alien (lispa) 108 (let ((a (make-alien (unsigned 8) (length lispa)))) 109 (clone-octets-to-alien lispa a))) 111 ;; TODO 2024-09-19: maybe want to return values, second being the length? 112 (defun octets-to-alien-array (lispa) 113 (cast (octets-to-alien lispa) (array (unsigned 8)))) 115 (defun clone-octets-from-alien (aliena lispa &optional len) 116 (declare (optimize (speed 3)) 118 (unless len (setf len (length lispa))) 119 (loop for i from 0 below len 120 do (setf (aref lispa i) 124 (defun foreign-int-to-integer (buffer size) 125 "Check SIZE of int BUFFER. return BUFFER." 126 (assert (= size (sb-alien:alien-size sb-alien:int :bytes))) 129 (defun foreign-int-to-bool (x size) 130 (if (zerop (foreign-int-to-integer x size)) 134 (defun bool-to-foreign-int (val) 137 (define-condition invalid-enum-variant (simple-error) ()) 138 (define-condition invalid-enum-value (simple-error) ()) 140 (defun invalid-enum-variant (var enum) 141 (error 'invalid-enum-variant 142 :format-control "~A is not a variant of enum ~A" 143 :format-arguments (list var enum))) 145 (defun invalid-enum-value (var enum) 146 (error 'invalid-enum-value 147 :format-control "~A is not a value associated with a variant of enum ~A" 148 :format-arguments (list var enum))) 150 (defmacro define-alien-enum ((name type &key (test 'eql) (default :error)) &rest forms) 151 "Define a pseudo-enum type, used to work-around difficulties working with 152 SB-ALIEN, groveller, typedef enums, etc. 154 NAME specified the name of the alien-type and keyword-based lookup 155 function. Additionally a NAME* reverse-lookup function is provided. 157 Two hash-tables are defined in the environment of the accessor functions 158 containing the variants. These are technically exposed anaphors 159 %lisp-enum-table and %lisp-enum-table*." 160 (setf forms (loop for (k . v) on forms by #'cddr 163 (let ((%lisp-enum-table (make-hash-table :test test :size (length forms))) 164 (%lisp-enum-table* (make-hash-table :test 'equal :size (length forms)))) ; TODO: may want this to be EQL, 165 ; taking strings for now. 166 (mapc (lambda (x) (setf (gethash (car x) %lisp-enum-table) (eval (cadr x)))) forms) 167 (mapc (lambda (x) (setf (gethash (eval (cadr x)) %lisp-enum-table*) (car x))) forms) 169 (define-alien-type ,name ,type) 171 ,(format nil "Given a keyword naming a variant of ~A, return the associated value." name) 172 (let ((found (gethash ,val ,%lisp-enum-table ,default))) 173 ,@(when (eql default :error) 174 `((when (eql found :error) (invalid-enum-variant ,val ',name)))) 176 (defun ,(symbolicate name '*) (,val) 177 ,(format nil "Given a ~A, check that it is equal to one of the variants of ~A and return 178 it. This function returns a second value which indicates the name of the 179 variant associated with this value." type name) 180 (std:when-let ((found (gethash ,val ,%lisp-enum-table* 182 ,@(when (eql default :error) 183 `((when (eql found :error) (invalid-enum-value ,val ',name)))) 184 (values ,val found))))))) 187 (defmacro with-alien-slots (vars struct &body body) 188 "Create local symbol macros for each var in VARS to reference 189 foreign slots in STRUCT. Similar to WITH-SLOTS. 190 Each var can be of the form: 191 name name bound to slot of same name 192 (* name) name bound to pointer to slot of same name 193 (name slot-name) name bound to slot-name 194 (name :pointer slot-name) name bound to pointer to slot-name" 196 ,(loop for var in vars 199 (let ((p1 (first var)) (p2 (second var)) (p3 (third var))) 200 (if (eq (sb-int:keywordicate p1) :*) 201 `(,p2 (addr (slot ,struct ',p2))) 202 (if (eq (sb-int:keywordicate p2) :*) 203 `(,p1 (addr (slot ,struct ',p3))) 204 `(,p1 (slot ,struct ',p2))))) 205 `(,var (slot ,struct ',var)))) 209 "Return the number of CPU threads online." 210 (alien-funcall (extern-alien "sysconf" (function int int)) sb-unix:sc-nprocessors-onln)) 212 (defvar *cpus* (num-cpus)) 217 (define-alien-type loff-t long-long) 219 (define-alien-routine memset void (ptr (* t)) (constant int) (size size-t)) 220 (define-alien-routine memcpy void (dst (* t)) (src (* t)) (size size-t)) 221 (define-alien-routine posix-memalign int (box (* t)) (alignment size-t) (size size-t))