X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-alieneval.lisp;h=c66e364fde4afd5c0f444e80b09d324a472a073c;hb=3352db3a8b45bc544473915ef25a4708f386be36;hp=b596d2796c7ae3f46f6ffd5d0af75ca196ba93d7;hpb=08d05510b51708853ca998154d8096b21d85edab;p=sbcl.git diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index b596d27..c66e364 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -70,6 +70,14 @@ (make-heap-alien-info :type type :sap-form `(foreign-symbol-sap ',alien-name t))))) +(defun alien-value (symbol) + #!+sb-doc + "Returns the value of the alien variable bound to SYMBOL. Signals an +error if SYMBOL is not bound to an alien variable, or if the alien +variable is undefined." + (%heap-alien (or (info :variable :alien-info symbol) + (error 'unbound-variable :name symbol)))) + (defmacro extern-alien (name type &environment env) #!+sb-doc "Access the alien variable named NAME, assuming it is of type TYPE. This @@ -229,12 +237,38 @@ (defmacro make-alien (type &optional size &environment env) #!+sb-doc - "Allocate an alien of type TYPE and return an alien pointer to it. If SIZE -is supplied, how it is interpreted depends on TYPE. If TYPE is an array type, -SIZE is used as the first dimension for the allocated array. If TYPE is not an -array, then SIZE is the number of elements to allocate. The memory is -allocated using ``malloc'', so it can be passed to foreign functions which use -``free''." + "Allocate an alien of type TYPE in foreign heap, and return an alien +pointer to it. The allocated memory is not initialized, and may +contain garbage. The memory is allocated using malloc(3), so it can be +passed to foreign functions which use free(3), or released using +FREE-ALIEN. + +For alien stack allocation, see macro WITH-ALIEN. + +The TYPE argument is not evaluated. If SIZE is supplied, how it is +interpreted depends on TYPE: + + * When TYPE is a foreign array type, an array of that type is + allocated, and a pointer to it is returned. Note that you + must use DEREF to first access the arrey through the pointer. + + If supplied, SIZE is used as the first dimension for the array. + + * When TYPE is any other foreign type, then an object for that + type is allocated, and a pointer to it is returned. So + (make-alien int) returns a (* int). + + If SIZE is specified, then a block of that many objects is + allocated, with the result pointing to the first one. + +Examples: + + (defvar *foo* (make-alien (array char 10))) + (type-of *foo*) ; => (alien (* (array (signed 8) 10))) + (setf (deref (deref foo) 0) 10) ; => 10 + + (make-alien char 12) ; => (alien (* (signed 8))) +" (let ((alien-type (if (alien-type-p type) type (parse-alien-type type env)))) @@ -269,27 +303,77 @@ allocated using ``malloc'', so it can be passed to foreign functions which use ;; undesirable, in most uses of MAKE-ALIEN the %SAP-ALIEN ;; cannot be optimized away. `(locally (declare (muffle-conditions compiler-note)) - (%sap-alien (%make-alien (* ,(align-offset bits alignment) - ,size-expr)) + ;; FIXME: Do we really need the ASH/+7 here after ALIGN-OFFSET? + (%sap-alien (%make-alien (* ,(ash (+ 7 (align-offset bits alignment)) -3) + (the index ,size-expr))) ',(make-alien-pointer-type :to alien-type))))))) +(defun malloc-error (bytes errno) + (error 'simple-storage-condition + :format-control "~A: malloc() of ~S bytes failed." + :format-arguments (list (strerror errno) bytes))) + ;;; Allocate a block of memory at least BITS bits long and return a ;;; system area pointer to it. #!-sb-fluid (declaim (inline %make-alien)) -(defun %make-alien (bits) - (declare (type index bits)) - (alien-funcall (extern-alien "malloc" - (function system-area-pointer unsigned)) - (ash (the index (+ bits 7)) -3))) +(defun %make-alien (bytes) + (declare (type index bytes) + (optimize (sb!c:alien-funcall-saves-fp-and-pc 0))) + (let ((sap (alien-funcall (extern-alien "malloc" + (function system-area-pointer size-t)) + bytes))) + (if (and (not (eql 0 bytes)) (eql 0 (sap-int sap))) + (malloc-error bytes (get-errno)) + sap))) #!-sb-fluid (declaim (inline free-alien)) (defun free-alien (alien) #!+sb-doc - "Dispose of the storage pointed to by ALIEN. ALIEN must have been allocated - by MAKE-ALIEN or malloc(3)." + "Dispose of the storage pointed to by ALIEN. The ALIEN must have been +allocated by MAKE-ALIEN, MAKE-ALIEN-STRING or malloc(3)." (alien-funcall (extern-alien "free" (function (values) system-area-pointer)) (alien-sap alien)) nil) + +(declaim (type (sfunction * system-area-pointer) %make-alien-string)) +(defun %make-alien-string (string &key (start 0) end + (external-format :default) + (null-terminate t)) + ;; FIXME: This is slow. We want a function to get the length of the + ;; encoded string so we can allocate the foreign memory first and + ;; encode directly there. + (let* ((octets (string-to-octets string + :start start :end end + :external-format external-format + :null-terminate null-terminate)) + (count (length octets)) + (buf (%make-alien count))) + (sb!kernel:copy-ub8-to-system-area octets 0 buf 0 count) + buf)) + +(defun make-alien-string (string &rest rest + &key (start 0) end + (external-format :default) + (null-terminate t)) + "Copy part of STRING delimited by START and END into freshly +allocated foreign memory, freeable using free(3) or FREE-ALIEN. +Returns the allocated string as a (* CHAR) alien, and the number of +bytes allocated as secondary value. + +The string is encoded using EXTERNAL-FORMAT. If NULL-TERMINATE is +true (the default), the alien string is terminated by an additional +null byte. +" + (declare (ignore start end external-format null-terminate)) + (multiple-value-bind (sap bytes) + (apply #'%make-alien-string string rest) + (values (%sap-alien sap (parse-alien-type '(* char) nil)) + bytes))) + +(define-compiler-macro make-alien-string (&rest args) + `(multiple-value-bind (sap bytes) (%make-alien-string ,@args) + (values (%sap-alien sap ',(parse-alien-type '(* char) nil)) + bytes))) ;;;; the SLOT operator @@ -738,6 +822,10 @@ allocated using ``malloc'', so it can be passed to foreign functions which use (and (alien-value-p object) (alien-subtype-p (alien-value-type object) type))))) +(defun alien-value-typep (object type) + (when (alien-value-p object) + (alien-subtype-p (alien-value-type object) type))) + ;;;; ALIEN CALLBACKS ;;;; ;;;; See "Foreign Linkage / Callbacks" in the SBCL Internals manual. @@ -822,22 +910,31 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.") :local ,(alien-callback-accessor-form spec 'args-sap offset)) do (incf offset (alien-callback-argument-bytes spec env))) - ,(flet ((store (spec) + ,(flet ((store (spec real-type) (if spec `(setf (deref (sap-alien res-sap (* ,spec))) - (funcall function ,@arguments)) + ,(if real-type + `(the ,real-type + (funcall function ,@arguments)) + `(funcall function ,@arguments))) `(funcall function ,@arguments)))) (cond ((alien-void-type-p result-type) - (store nil)) + (store nil nil)) ((alien-integer-type-p result-type) + ;; Integer types should be padded out to a full + ;; register width, to comply with most ABI calling + ;; conventions, but should be typechecked on the + ;; declared type width, hence the following: (if (alien-integer-type-signed result-type) (store `(signed - ,(alien-type-word-aligned-bits result-type))) + ,(alien-type-word-aligned-bits result-type)) + `(signed-byte ,(alien-type-bits result-type))) (store `(unsigned - ,(alien-type-word-aligned-bits result-type))))) + ,(alien-type-word-aligned-bits result-type)) + `(unsigned-byte ,(alien-type-bits result-type))))) (t - (store (unparse-alien-type result-type))))))) + (store (unparse-alien-type result-type) nil)))))) (values)))) (defun invalid-alien-callback (&rest arguments)