GopherProxy

	tcffi-ecl.lisp - clic - Clic is an command line interactive client for gopher w…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tcffi-ecl.lisp (17282B)
	---
	1 ;;;; -- Mode: lisp; indent-tabs-mode: nil --
	2 ;;;
	3 ;;; cffi-ecl.lisp --- ECL backend for CFFI.
	4 ;;;
	5 ;;; Copyright (C) 2005-2006, James Bielman <[email protected]>
	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 ;;;# Administrivia
	29
	30 (defpackage #:cffi-sys
	31 (:use #:common-lisp #:alexandria)
	32 (:import-from #:si #:null-pointer-p)
	33 (:export
	34 #:cffi-ecl-method
	35 #:canonicalize-symbol-name-case
	36 #:foreign-pointer
	37 #:pointerp
	38 #:pointer-eq
	39 #:%foreign-alloc
	40 #:foreign-free
	41 #:with-foreign-pointer
	42 #:null-pointer
	43 #:null-pointer-p
	44 #:inc-pointer
	45 #:make-pointer
	46 #:pointer-address
	47 #:%mem-ref
	48 #:%mem-set
	49 #:%foreign-funcall
	50 #:%foreign-funcall-pointer
	51 #:%foreign-funcall-varargs
	52 #:%foreign-funcall-pointer-varargs
	53 #:%foreign-type-alignment
	54 #:%foreign-type-size
	55 #:%load-foreign-library
	56 #:%close-foreign-library
	57 #:native-namestring
	58 #:make-shareable-byte-vector
	59 #:with-pointer-to-vector-data
	60 #:%defcallback
	61 #:%callback
	62 #:%foreign-symbol-pointer))
	63
	64 (in-package #:cffi-sys)
	65
	66 ;;;
	67 ;;; ECL allows many ways of calling a foreign function, and also many
	68 ;;; ways of finding the pointer associated to a function name. They
	69 ;;; depend on whether the FFI relies on libffi or on the C/C++ compiler,
	70 ;;; and whether they use the shared library loader to locate symbols
	71 ;;; or they are linked by the linker.
	72 ;;;
	73 ;;; :DFFI
	74 ;;;
	75 ;;; ECL uses libffi to call foreign functions. The only way to find out
	76 ;;; foreign symbols is by loading shared libraries and using dlopen()
	77 ;;; or similar.
	78 ;;;
	79 ;;; :DLOPEN
	80 ;;;
	81 ;;; ECL compiles FFI code as C/C++ statements. The names are resolved
	82 ;;; at run time by the shared library loader every time the function
	83 ;;; is called
	84 ;;;
	85 ;;; :C/C++
	86 ;;;
	87 ;;; ECL compiles FFI code as C/C++ statements, but the name resolution
	88 ;;; happens at link time. In this case you have to tell the ECL
	89 ;;; compiler which are the right ld-flags (c:ld-flags) to link in
	90 ;;; the library.
	91 ;;;
	92 (defvar cffi-ecl-method
	93 #+dffi :dffi
	94 #+(and dlopen (not dffi)) :dlopen
	95 #-(or dffi dlopen) :c/c++
	96 "The type of code that CFFI generates for ECL: :DFFI when using the
	97 dynamical foreign function interface; :DLOPEN when using C code and
	98 dynamical references to symbols; :C/C++ for C/C++ code with static
	99 references to symbols.")
	100
	101 ;;;# Mis-features
	102
	103 #-long-long
	104 (pushnew 'no-long-long features)
	105 (pushnew 'flat-namespace features)
	106
	107 ;;;# Symbol Case
	108
	109 (defun canonicalize-symbol-name-case (name)
	110 (declare (string name))
	111 (string-upcase name))
	112
	113 ;;;# Allocation
	114
	115 (defun %foreign-alloc (size)
	116 "Allocate SIZE bytes of foreign-addressable memory."
	117 (si:allocate-foreign-data :void size))
	118
	119 (defun foreign-free (ptr)
	120 "Free a pointer PTR allocated by FOREIGN-ALLOC."
	121 (si:free-foreign-data ptr))
	122
	123 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
	124 "Bind VAR to SIZE bytes of foreign memory during BODY. The
	125 pointer in VAR is invalid beyond the dynamic extent of BODY, and
	126 may be stack-allocated if supported by the implementation. If
	127 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
	128 (unless size-var
	129 (setf size-var (gensym "SIZE")))
	130 `(let* ((,size-var ,size)
	131 (,var (%foreign-alloc ,size-var)))
	132 (unwind-protect
	133 (progn ,@body)
	134 (foreign-free ,var))))
	135
	136 ;;;# Misc. Pointer Operations
	137
	138 (deftype foreign-pointer ()
	139 'si:foreign-data)
	140
	141 (defun null-pointer ()
	142 "Construct and return a null pointer."
	143 (si:allocate-foreign-data :void 0))
	144
	145 (defun inc-pointer (ptr offset)
	146 "Return a pointer OFFSET bytes past PTR."
	147 (ffi:make-pointer (+ (ffi:pointer-address ptr) offset) :void))
	148
	149 (defun pointerp (ptr)
	150 "Return true if PTR is a foreign pointer."
	151 (typep ptr 'si:foreign-data))
	152
	153 (defun pointer-eq (ptr1 ptr2)
	154 "Return true if PTR1 and PTR2 point to the same address."
	155 (= (ffi:pointer-address ptr1) (ffi:pointer-address ptr2)))
	156
	157 (defun make-pointer (address)
	158 "Return a pointer pointing to ADDRESS."
	159 (ffi:make-pointer address :void))
	160
	161 (defun pointer-address (ptr)
	162 "Return the address pointed to by PTR."
	163 (ffi:pointer-address ptr))
	164
	165 ;;;# Shareable Vectors
	166 ;;;
	167 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
	168 ;;; should be defined to perform a copy-in/copy-out if the Lisp
	169 ;;; implementation can't do this.
	170
	171 (defun make-shareable-byte-vector (size)
	172 "Create a Lisp vector of SIZE bytes that can passed to
	173 WITH-POINTER-TO-VECTOR-DATA."
	174 (make-array size :element-type '(unsigned-byte 8)))
	175
	176 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
	177 "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
	178 `(let ((,ptr-var (si:make-foreign-data-from-array ,vector)))
	179 ,@body))
	180
	181 ;;;# Type Operations
	182
	183 (defconstant +translation-table+
	184 '((:char :byte "char")
	185 (:unsigned-char :unsigned-byte "unsigned char")
	186 (:short :short "short")
	187 (:unsigned-short :unsigned-short "unsigned short")
	188 (:int :int "int")
	189 (:unsigned-int :unsigned-int "unsigned int")
	190 (:long :long "long")
	191 (:unsigned-long :unsigned-long "unsigned long")
	192 #+long-long
	193 (:long-long :long-long "long long")
	194 #+long-long
	195 (:unsigned-long-long :unsigned-long-long "unsigned long long")
	196 (:float :float "float")
	197 (:double :double "double")
	198 (:pointer :pointer-void "void*")
	199 (:void :void "void")))
	200
	201 (defun cffi-type->ecl-type (type-keyword)
	202 "Convert a CFFI type keyword to an ECL type keyword."
	203 (or (second (find type-keyword +translation-table+ :key #'first))
	204 (error "~S is not a valid CFFI type" type-keyword)))
	205
	206 (defun ecl-type->c-type (type-keyword)
	207 "Convert a CFFI type keyword to an valid C type keyword."
	208 (or (third (find type-keyword +translation-table+ :key #'second))
	209 (error "~S is not a valid CFFI type" type-keyword)))
	210
	211 (defun %foreign-type-size (type-keyword)
	212 "Return the size in bytes of a foreign type."
	213 (nth-value 0 (ffi:size-of-foreign-type
	214 (cffi-type->ecl-type type-keyword))))
	215
	216 (defun %foreign-type-alignment (type-keyword)
	217 "Return the alignment in bytes of a foreign type."
	218 (nth-value 1 (ffi:size-of-foreign-type
	219 (cffi-type->ecl-type type-keyword))))
	220
	221 ;;;# Dereferencing
	222
	223 (defun %mem-ref (ptr type &optional (offset 0))
	224 "Dereference an object of TYPE at OFFSET bytes from PTR."
	225 (let* ((type (cffi-type->ecl-type type))
	226 (type-size (ffi:size-of-foreign-type type)))
	227 (si:foreign-data-ref-elt
	228 (si:foreign-data-recast ptr (+ offset type-size) :void) offset type…
	229
	230 (defun %mem-set (value ptr type &optional (offset 0))
	231 "Set an object of TYPE at OFFSET bytes from PTR."
	232 (let* ((type (cffi-type->ecl-type type))
	233 (type-size (ffi:size-of-foreign-type type)))
	234 (si:foreign-data-set-elt
	235 (si:foreign-data-recast ptr (+ offset type-size) :void)
	236 offset type value)))
	237
	238 ;;; Inline versions that use C expressions instead of function calls.
	239
	240 (defparameter +mem-ref-strings+
	241 (loop for (cffi-type ecl-type c-string) in +translation-table+
	242 for string = (format nil "((~A )(((char*)#0)+#1))" c-string)
	243 collect (list cffi-type ecl-type string)))
	244
	245 (defparameter +mem-set-strings+
	246 (loop for (cffi-type ecl-type c-string) in +translation-table+
	247 for string = (format nil "((~A )(((char*)#0)+#1))=#2" c-string)
	248 collect (list cffi-type ecl-type string)))
	249
	250 (define-compiler-macro %mem-ref (&whole whole ptr type &optional (offset…
	251 (if (and (constantp type) (constantp offset))
	252 (let ((record (assoc (eval type) +mem-ref-strings+)))
	253 `(ffi:c-inline (,ptr ,offset)
	254 (:pointer-void :cl-index) ; argument types
	255 ,(second record) ; return type
	256 ,(third record) ; the precomputed expansion
	257 :one-liner t))
	258 whole))
	259
	260 (define-compiler-macro %mem-set (&whole whole value ptr type &optional (…
	261 (if (and (constantp type) (constantp offset))
	262 (let ((record (assoc (eval type) +mem-set-strings+)))
	263 `(ffi:c-inline (,ptr ,offset ,value) ; arguments with type trans…
	264 (:pointer-void :cl-index ,(second record))
	265 :void ; does not return anything
	266 ,(third record) ; precomputed expansion
	267 :one-liner t))
	268 whole))
	269
	270 ;;;# Calling Foreign Functions
	271
	272 (defconstant +ecl-inline-codes+ "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,…
	273
	274 (defun c-inline-function-call (thing fixed-types types values return-typ…
	275 (when dynamic-call
	276 (when (stringp thing)
	277 (setf thing `(%foreign-symbol-pointer ,thing nil)))
	278 (push thing values)
	279 (push :pointer-void types))
	280 (let* ((decl-args
	281 (format nil "~{~A~^, ~}~A"
	282 (mapcar #'ecl-type->c-type fixed-types) (if (null vari…
	283 (call-args
	284 (if dynamic-call
	285 ;; #0 is already used in a cast (it is a function pointer)
	286 (subseq +ecl-inline-codes+ 3 (max 3 (1- (* (length values)…
	287 ;; #0 is not used, so we start from the beginning
	288 (subseq +ecl-inline-codes+ 0 (max 0 (1- (* (length values)…
	289 (clines
	290 (if dynamic-call
	291 nil
	292 (format nil "extern ~A ~A(~A);"
	293 (ecl-type->c-type return-type) thing decl-args)))
	294 (call-code
	295 (if dynamic-call
	296 (format nil "((~A (*)(~A))(#0))(~A)"
	297 (ecl-type->c-type return-type) decl-args call-args)
	298 (format nil "~A(~A)" thing call-args))))
	299 `(progn
	300 (ffi:clines ,@(ensure-list clines))
	301 (ffi:c-inline ,values ,types ,return-type ,call-code :one-liner t…
	302
	303 (defun dffi-function-pointer-call (pointer types values return-type)
	304 (when (stringp pointer)
	305 (setf pointer `(%foreign-symbol-pointer ,pointer nil)))
	306 #-dffi
	307 `(error "In interpreted code, attempted to call a foreign function~% ~…
	308 but ECL was built without support for that." ,pointer)
	309 #+dffi
	310 `(si::call-cfun ,pointer ,return-type (list ,@types) (list ,@values)))
	311
	312 (defun foreign-funcall-parse-args (args)
	313 "Return three values, lists of arg types, values, and result type."
	314 (let ((return-type :void))
	315 (loop for (type arg) on args by #'cddr
	316 if arg collect (cffi-type->ecl-type type) into types
	317 and collect arg into values
	318 else do (setf return-type (cffi-type->ecl-type type))
	319 finally (return (values types values return-type)))))
	320
	321 (defmacro %foreign-funcall (name args &key library convention)
	322 "Call a foreign function."
	323 (declare (ignore library convention))
	324 (multiple-value-bind (types values return-type)
	325 (foreign-funcall-parse-args args)
	326 `(ext:with-backend
	327 :bytecodes
	328 ,(dffi-function-pointer-call name types values return-type)
	329 :c/c++
	330 ,(ecase cffi-ecl-method
	331 (:dffi (dffi-function-pointer-call name types values return-t…
	332 (:dlopen (c-inline-function-call name types types values return…
	333 (:c/c++ (c-inline-function-call name types types values return…
	334
	335 (defmacro %foreign-funcall-pointer (pointer args &key convention)
	336 "Funcall a pointer to a foreign function."
	337 (declare (ignore convention))
	338 (multiple-value-bind (types values return-type)
	339 (foreign-funcall-parse-args args)
	340 `(ext:with-backend
	341 :bytecodes
	342 ,(dffi-function-pointer-call pointer types values return-type)
	343 :c/c++
	344 ,(if (eq cffi-ecl-method :dffi)
	345 (dffi-function-pointer-call pointer types values return-type)
	346 (c-inline-function-call pointer types types values return-typ…
	347
	348 (defmacro %foreign-funcall-varargs (name args varargs &key library conve…
	349 (declare (ignore library convention))
	350 (multiple-value-bind (fixed-types fixed-values)
	351 (foreign-funcall-parse-args args)
	352 (multiple-value-bind (varargs-types varargs-values return-type)
	353 (foreign-funcall-parse-args varargs)
	354 (let ((all-types (append fixed-types varargs-types))
	355 (values (append fixed-values varargs-values)))
	356 `(ext:with-backend
	357 :bytecodes
	358 ,(dffi-function-pointer-call name all-types values return-type)
	359 :c/c++
	360 ,(ecase cffi-ecl-method
	361 (:dffi (dffi-function-pointer-call name all-types values r…
	362 (:dlopen (c-inline-function-call name fixed-types all-types …
	363 (:c/c++ (c-inline-function-call name fixed-types all-types …
	364
	365 (defmacro %foreign-funcall-pointer-varargs (pointer args varargs &key co…
	366 (declare (ignore convention))
	367 (multiple-value-bind (fixed-types fixed-values)
	368 (foreign-funcall-parse-args args)
	369 (multiple-value-bind (varargs-types varargs-values return-type)
	370 (foreign-funcall-parse-args varargs)
	371 (let ((all-types (append fixed-types varargs-types))
	372 (values (append fixed-values varargs-values)))
	373 `(ext:with-backend
	374 :bytecodes
	375 ,(dffi-function-pointer-call pointer all-types values return-ty…
	376 :c/c++
	377 ,(if (eq cffi-ecl-method :dffi)
	378 (dffi-function-pointer-call pointer all-types values return-…
	379 (c-inline-function-call pointer fixed-types all-types values…
	380
	381 ;;;# Foreign Libraries
	382
	383 (defun %load-foreign-library (name path)
	384 "Load a foreign library."
	385 (declare (ignore name))
	386 #-dffi (error "LOAD-FOREIGN-LIBRARY requires ECL's DFFI support. Use ~
	387 FFI:LOAD-FOREIGN-LIBRARY with a constant argument inste…
	388 #+dffi
	389 (handler-case (si:load-foreign-module path)
	390 (file-error ()
	391 (error "file error while trying to load `~A'" path))))
	392
	393 (defun %close-foreign-library (handle)
	394 "Close a foreign library."
	395 (handler-case (si::unload-foreign-module handle)
	396 (undefined-function ()
	397 (restart-case (error "Detected ECL prior to version 15.2.21. ~
	398 Function CFFI:CLOSE-FOREIGN-LIBRARY isn't im…
	399 (ignore () :report "Continue anyway (foreign library will remain…
	400
	401 (defun native-namestring (pathname)
	402 (namestring pathname))
	403
	404 ;;;# Callbacks
	405
	406 ;;; Create a package to contain the symbols for callback functions.
	407 ;;; We want to redefine callbacks with the same symbol so the internal
	408 ;;; data structures are reused.
	409 (defpackage #:cffi-callbacks
	410 (:use))
	411
	412 (defvar callbacks (make-hash-table))
	413
	414 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the
	415 ;;; internal callback for NAME.
	416 (eval-when (:compile-toplevel :load-toplevel :execute)
	417 (defun intern-callback (name)
	418 (intern (format nil "~A::~A"
	419 (if-let (package (symbol-package name))
	420 (package-name package)
	421 "#")
	422 (symbol-name name))
	423 '#:cffi-callbacks)))
	424
	425 (defmacro %defcallback (name rettype arg-names arg-types body
	426 &key convention)
	427 (declare (ignore convention))
	428 (let ((cb-name (intern-callback name))
	429 (cb-type #.(if (> ext:+ecl-version-number+ 160102)
	430 :default :cdecl)))
	431 `(progn
	432 (ffi:defcallback (,cb-name ,cb-type)
	433 ,(cffi-type->ecl-type rettype)
	434 ,(mapcar #'list arg-names
	435 (mapcar #'cffi-type->ecl-type arg-types))
	436 ,body)
	437 (setf (gethash ',name callbacks) ',cb-name))))
	438
	439 (defun %callback (name)
	440 (multiple-value-bind (symbol winp)
	441 (gethash name callbacks)
	442 (unless winp
	443 (error "Undefined callback: ~S" name))
	444 (ffi:callback symbol)))
	445
	446 ;;;# Foreign Globals
	447
	448 (defun %foreign-symbol-pointer (name library)
	449 "Returns a pointer to a foreign symbol NAME."
	450 (declare (ignore library))
	451 (handler-case
	452 (si:find-foreign-symbol (coerce name 'base-string)
	453 :default :pointer-void 0)
	454 (error (c) nil)))