changeset 657: |
937a6f354047 |
parent: |
93ea0386a0c8
|
child: |
804b5ee20a46 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Wed, 18 Sep 2024 21:48:06 -0400 |
permissions: |
-rw-r--r-- |
description: |
zstd tests and macros |
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 aliena) 103 (declare (optimize (speed 3))) 104 (loop for i from 0 below (length lispa) 105 do (setf (deref aliena i) 109 (defmacro octets-to-alien (lispa) 111 `(with-alien ((,a (array (unsigned 8) ,(length lispa)))) 112 (clone-octets-to-alien ,lispa ,a)))) 114 (defun clone-octets-from-alien (aliena lispa &optional len) 115 (declare (optimize (speed 3)) 117 (unless len (setf len (length lispa))) 118 (loop for i from 0 below len 119 do (setf (aref lispa i) 123 (defun foreign-int-to-integer (buffer size) 124 "Check SIZE of int BUFFER. return BUFFER." 125 (assert (= size (sb-alien:alien-size sb-alien:int :bytes))) 128 (defun foreign-int-to-bool (x size) 129 (if (zerop (foreign-int-to-integer x size)) 133 (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))) 151 (defmacro define-alien-enum ((name type &key (test 'eql) (default :error)) &rest forms) 152 "Define a pseudo-enum type, used to work-around difficulties working with 153 SB-ALIEN, groveller, typedef enums, etc. 155 NAME specified the name of the alien-type and keyword-based lookup 156 function. Additionally a NAME* reverse-lookup function is provided. 158 Two hash-tables are defined in the environment of the accessor functions 159 containing the variants. These are technically exposed anaphors 160 %lisp-enum-table and %lisp-enum-table*." 161 (setf forms (loop for (k . v) on forms by #'cddr 164 (let ((%lisp-enum-table (make-hash-table :test test :size (length forms))) 165 (%lisp-enum-table* (make-hash-table :test 'equal :size (length forms)))) ; TODO: may want this to be EQL, 166 ; taking strings for now. 167 (mapc (lambda (x) (setf (gethash (car x) %lisp-enum-table) (eval (cadr x)))) forms) 168 (mapc (lambda (x) (setf (gethash (eval (cadr x)) %lisp-enum-table*) (car x))) forms) 170 (define-alien-type ,name ,type) 172 ,(format nil "Given a keyword naming a variant of ~A, return the associated value." name) 173 (let ((found (gethash ,val ,%lisp-enum-table ,default))) 174 ,@(when (eql default :error) 175 `((when (eql found :error) (invalid-enum-variant ,val ',name)))) 177 (defun ,(symbolicate name '*) (,val) 178 ,(format nil "Given a ~A, check that it is equal to one of the variants of ~A and return 179 it. This function returns a second value which indicates the name of the 180 variant associated with this value." type name) 181 (std:when-let ((found (gethash ,val ,%lisp-enum-table* 183 ,@(when (eql default :error) 184 `((when (eql found :error) (invalid-enum-value ,val ',name)))) 185 (values ,val found))))))) 188 "Return the number of CPU threads online." 189 (alien-funcall (extern-alien "sysconf" (function int int)) sb-unix:sc-nprocessors-onln)) 191 (defvar *cpus* (num-cpus)) 196 (define-alien-type loff-t long-long) 198 (define-alien-routine memset void (ptr (* t)) (constant int) (size size-t))