changeset 678: |
2b7d5a8d63ac |
parent: |
804b5ee20a46
|
child: |
5f88b237ce29 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Wed, 25 Sep 2024 21:39:39 -0400 |
permissions: |
-rw-r--r-- |
description: |
alien octets fix, workin with org-graph-db |
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 (define-alien-type ,ty (struct ,(or foreign-type (symbolicate ty '-t)))) 58 ,(unless no-export `(export '(,ty))))) 60 (defun setfa (place from) 61 (loop for x across from 62 for i from 0 below (length from) 63 do (setf (deref place i) x))) 65 (defun copy-c-string (src dest &aux (index 0)) 66 (declare (type sb-int:index index)) 67 (loop (let ((b (sb-sys:sap-ref-8 src index))) 69 (setf (fill-pointer dest) index) 71 (setf (char dest index) (code-char b)) 74 (defun clone-strings (list) 75 (with-alien ((x (* (* char)) 76 (make-alien (* char) (length list)))) 78 (labels ((populate (list index function) 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) function))) 88 (loop for i below (length list) 89 do (print (cast (deref x i) c-string)))))) 92 (defun c-strings-to-string-list (c-strings) 93 (declare (type (alien (* c-string)) c-strings)) 94 (let ((reversed-result nil)) 95 (dotimes (i most-positive-fixnum) 96 (declare (type sb-int:index i)) 97 (let ((c-string (deref c-strings i))) 99 (push c-string reversed-result) 100 (return (nreverse reversed-result))))))) 102 (defun clone-octets-to-alien (lispa alien) 103 (declare (optimize (speed 3)) 104 ((vector (unsigned-byte 8)) lispa)) 105 ;; (setf aliena (cast aliena (array (unsigned 8)))) 106 (loop for i from 0 below (length lispa) 107 do (setf (deref alien i) 111 (defun octets-to-alien (lispa) 112 (let ((a (make-alien (unsigned 8) (length lispa)))) 113 (clone-octets-to-alien lispa a))) 115 ;; TODO 2024-09-19: maybe want to return values, second being the length? 116 (defun octets-to-alien-array (lispa) 117 (cast (octets-to-alien lispa) (array (unsigned 8)))) 119 (defun clone-octets-from-alien (aliena lispa &optional len) 120 (declare (optimize (speed 3)) 122 (unless len (setf len (length lispa))) 123 (loop for i from 0 below len 124 do (setf (aref lispa i) 128 (defun foreign-int-to-integer (buffer size) 129 "Check SIZE of int BUFFER. return BUFFER." 130 (assert (= size (sb-alien:alien-size sb-alien:int :bytes))) 133 (defun foreign-int-to-bool (x size) 134 (if (zerop (foreign-int-to-integer x size)) 138 (defun bool-to-foreign-int (val) 141 (define-condition invalid-enum-variant (simple-error) ()) 142 (define-condition invalid-enum-value (simple-error) ()) 144 (defun invalid-enum-variant (var enum) 145 (error 'invalid-enum-variant 146 :format-control "~A is not a variant of enum ~A" 147 :format-arguments (list var enum))) 149 (defun invalid-enum-value (var enum) 150 (error 'invalid-enum-value 151 :format-control "~A is not a value associated with a variant of enum ~A" 152 :format-arguments (list var enum))) 154 (defmacro define-alien-enum ((name type &key (test 'eql) (default :error)) &rest forms) 155 "Define a pseudo-enum type, used to work-around difficulties working with 156 SB-ALIEN, groveller, typedef enums, etc. 158 NAME specified the name of the alien-type and keyword-based lookup 159 function. Additionally a NAME* reverse-lookup function is provided. 161 Two hash-tables are defined in the environment of the accessor functions 162 containing the variants. These are technically exposed anaphors 163 %lisp-enum-table and %lisp-enum-table*." 164 (setf forms (loop for (k . v) on forms by #'cddr 167 (let ((%lisp-enum-table (make-hash-table :test test :size (length forms))) 168 (%lisp-enum-table* (make-hash-table :test 'equal :size (length forms)))) ; TODO: may want this to be EQL, 169 ; taking strings for now. 170 (mapc (lambda (x) (setf (gethash (car x) %lisp-enum-table) (eval (cadr x)))) forms) 171 (mapc (lambda (x) (setf (gethash (eval (cadr x)) %lisp-enum-table*) (car x))) forms) 173 (define-alien-type ,name ,type) 175 ,(format nil "Given a keyword naming a variant of ~A, return the associated value." name) 176 (let ((found (gethash ,val ,%lisp-enum-table ,default))) 177 ,@(when (eql default :error) 178 `((when (eql found :error) (invalid-enum-variant ,val ',name)))) 180 (defun ,(symbolicate name '*) (,val) 181 ,(format nil "Given a ~A, check that it is equal to one of the variants of ~A and return 182 it. This function returns a second value which indicates the name of the 183 variant associated with this value." type name) 184 (std:when-let ((found (gethash ,val ,%lisp-enum-table* 186 ,@(when (eql default :error) 187 `((when (eql found :error) (invalid-enum-value ,val ',name)))) 188 (values ,val found))))))) 191 (defmacro with-alien-slots (vars struct &body body) 192 "Create local symbol macros for each var in VARS to reference 193 foreign slots in STRUCT. Similar to WITH-SLOTS. 194 Each var can be of the form: 195 name name bound to slot of same name 196 (* name) name bound to pointer to slot of same name 197 (name slot-name) name bound to slot-name 198 (name :pointer slot-name) name bound to pointer to slot-name" 200 ,(loop for var in vars 203 (let ((p1 (first var)) (p2 (second var)) (p3 (third var))) 204 (if (eq (sb-int:keywordicate p1) :*) 205 `(,p2 (addr (slot ,struct ',p2))) 206 (if (eq (sb-int:keywordicate p2) :*) 207 `(,p1 (addr (slot ,struct ',p3))) 208 `(,p1 (slot ,struct ',p2))))) 209 `(,var (slot ,struct ',var)))) 213 "Return the number of CPU threads online." 214 (alien-funcall (extern-alien "sysconf" (function int int)) sb-unix:sc-nprocessors-onln)) 216 (defvar *cpus* (num-cpus)) 221 (define-alien-type loff-t long-long) 223 (define-alien-routine memset void (ptr (* t)) (constant int) (size size-t))