;; is allocated at load time, so the same piece of memory is used each time
;; this form executes.
(/show "entering WITH-ALIEN" bindings)
- (let (bind-alien-stack)
- (with-auxiliary-alien-types env
- (dolist (binding (reverse bindings))
- (/show binding)
- (destructuring-bind
- (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p))
- binding
- (/show symbol type opt1 opt2)
- (let* ((alien-type (parse-alien-type type env))
- (datap (not (alien-fun-type-p alien-type))))
- (/show alien-type)
- (multiple-value-bind (allocation initial-value)
- (if opt2p
- (values opt1 opt2)
- (case opt1
- (:extern
- (values opt1 (guess-alien-name-from-lisp-name symbol)))
- (:static
- (values opt1 nil))
- (t
- (values :local opt1))))
- (/show allocation initial-value)
- (setf body
- (ecase allocation
- #+nil
- (:static
- (let ((sap
- (make-symbol (concatenate 'string "SAP-FOR-"
- (symbol-name symbol)))))
- `((let ((,sap (load-time-value (%make-alien ...))))
- (declare (type system-area-pointer ,sap))
- (symbol-macrolet
- ((,symbol (sap-alien ,sap ,type)))
- ,@(when initial-value
- `((setq ,symbol ,initial-value)))
- ,@body)))))
- (:extern
- (/show0 ":EXTERN case")
- (let ((info (make-heap-alien-info
- :type alien-type
- :sap-form `(foreign-symbol-sap ',initial-value
- ,datap))))
- `((symbol-macrolet
- ((,symbol (%heap-alien ',info)))
- ,@body))))
- (:local
- (/show0 ":LOCAL case")
- (let* ((var (gensym))
- (initval (if initial-value (gensym)))
- (info (make-local-alien-info :type alien-type))
- (inner-body
- `((note-local-alien-type ',info ,var)
- (symbol-macrolet ((,symbol (local-alien ',info ,var)))
- ,@(when initial-value
- `((setq ,symbol ,initval)))
- ,@body)))
- (body-forms
- (if initial-value
- `((let ((,initval ,initial-value))
- ,@inner-body))
- inner-body)))
- (/show var initval info)
- #!+(or x86 x86-64)
- (progn
- (setf bind-alien-stack t)
- `((let ((,var (make-local-alien ',info)))
- ,@body-forms)))
- ;; FIXME: This version is less efficient then it needs to be, since
- ;; it could just save and restore the number-stack pointer once,
- ;; instead of doing multiple decrements if there are multiple bindings.
- #!-(or x86 x86-64)
- `((let (,var)
- (unwind-protect
- (progn
- (setf ,var (make-local-alien ',info))
- (let ((,var ,var))
- ,body-form))
- (dispose-local-alien ',info ,var))))))))))))
- (/show "revised" body)
- (verify-local-auxiliaries-okay)
- (/show0 "back from VERIFY-LOCAL-AUXILIARIES-OK, returning")
- `(symbol-macrolet ((&auxiliary-type-definitions&
- ,(append *new-auxiliary-types*
- (auxiliary-type-definitions env))))
- ,@(if bind-alien-stack
- `((let ((sb!vm::*alien-stack* sb!vm::*alien-stack*))
- ,@body))
- body)))))
+ (with-auxiliary-alien-types env
+ (dolist (binding (reverse bindings))
+ (/show binding)
+ (destructuring-bind
+ (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p))
+ binding
+ (/show symbol type opt1 opt2)
+ (let* ((alien-type (parse-alien-type type env))
+ (datap (not (alien-fun-type-p alien-type))))
+ (/show alien-type)
+ (multiple-value-bind (allocation initial-value)
+ (if opt2p
+ (values opt1 opt2)
+ (case opt1
+ (:extern
+ (values opt1 (guess-alien-name-from-lisp-name symbol)))
+ (:static
+ (values opt1 nil))
+ (t
+ (values :local opt1))))
+ (/show allocation initial-value)
+ (setf body
+ (ecase allocation
+ #+nil
+ (:static
+ (let ((sap
+ (make-symbol (concatenate 'string "SAP-FOR-"
+ (symbol-name symbol)))))
+ `((let ((,sap (load-time-value (%make-alien ...))))
+ (declare (type system-area-pointer ,sap))
+ (symbol-macrolet
+ ((,symbol (sap-alien ,sap ,type)))
+ ,@(when initial-value
+ `((setq ,symbol ,initial-value)))
+ ,@body)))))
+ (:extern
+ (/show0 ":EXTERN case")
+ (let ((info (make-heap-alien-info
+ :type alien-type
+ :sap-form `(foreign-symbol-sap ',initial-value
+ ,datap))))
+ `((symbol-macrolet
+ ((,symbol (%heap-alien ',info)))
+ ,@body))))
+ (:local
+ (/show0 ":LOCAL case")
+ (let* ((var (sb!xc:gensym "VAR"))
+ (initval (if initial-value (sb!xc:gensym "INITVAL")))
+ (info (make-local-alien-info :type alien-type))
+ (inner-body
+ `((note-local-alien-type ',info ,var)
+ (symbol-macrolet ((,symbol (local-alien ',info ,var)))
+ ,@(when initial-value
+ `((setq ,symbol ,initval)))
+ ,@body)))
+ (body-forms
+ (if initial-value
+ `((let ((,initval ,initial-value))
+ ,@inner-body))
+ inner-body)))
+ (/show var initval info)
+ #!+(or x86 x86-64)
+ `((let ((,var (make-local-alien ',info)))
+ ,@body-forms))
+ ;; FIXME: This version is less efficient then it needs to be, since
+ ;; it could just save and restore the number-stack pointer once,
+ ;; instead of doing multiple decrements if there are multiple bindings.
+ #!-(or x86 x86-64)
+ `((let (,var)
+ (unwind-protect
+ (progn
+ (setf ,var (make-local-alien ',info))
+ (let ((,var ,var))
+ ,@body-forms))
+ (dispose-local-alien ',info ,var))))))))))))
+ (/show "revised" body)
+ (verify-local-auxiliaries-okay)
+ (/show0 "back from VERIFY-LOCAL-AUXILIARIES-OK, returning")
+ `(symbol-macrolet ((&auxiliary-type-definitions&
+ ,(append *new-auxiliary-types*
+ (auxiliary-type-definitions env))))
+ #!+(or x86 x86-64)
+ (let ((sb!vm::*alien-stack* sb!vm::*alien-stack*))
+ ,@body)
+ #!-(or x86 x86-64)
+ ,@body)))
\f
;;;; runtime C values that don't correspond directly to Lisp types
(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))))
#!-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 (* 8 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)))
\f
;;;; the SLOT operator
(let ((stub (alien-fun-type-stub type)))
(unless stub
(setf stub
- (let ((fun (gensym))
+ (let ((fun (sb!xc:gensym "FUN"))
(parms (make-gensym-list (length args))))
(compile nil
`(lambda (,fun ,@parms)
((,lisp-name (function ,result-type ,@(arg-types))
:extern ,alien-name)
,@(alien-vars))
- #-nil
- (values (alien-funcall ,lisp-name ,@(alien-args))
- ,@(results))
- #+nil
- (if (alien-values-type-p result-type)
- ;; FIXME: RESULT-TYPE is a type specifier, so it
- ;; cannot be of type ALIEN-VALUES-TYPE. Also note,
- ;; that if RESULT-TYPE is VOID, then this code
- ;; disagrees with the computation of the return type
- ;; and with all usages of this macro. -- APD,
- ;; 2002-03-02
- (let ((temps (make-gensym-list
- (length
- (alien-values-type-values result-type)))))
- `(multiple-value-bind ,temps
- (alien-funcall ,lisp-name ,@(alien-args))
- (values ,@temps ,@(results))))
- (values (alien-funcall ,lisp-name ,@(alien-args))
- ,@(results)))))))))
+ ,@(if (eq 'void result-type)
+ `((alien-funcall ,lisp-name ,@(alien-args))
+ (values nil ,@(results)))
+ `((values (alien-funcall ,lisp-name ,@(alien-args))
+ ,@(results))))))))))
\f
(defun alien-typep (object type)
#!+sb-doc
: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)