projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
1.0.14.36: faster PROPAGATE-FROM-SETS
[sbcl.git]
/
src
/
code
/
target-alieneval.lisp
diff --git
a/src/code/target-alieneval.lisp
b/src/code/target-alieneval.lisp
index
2b133cd
..
d674b64
100644
(file)
--- a/
src/code/target-alieneval.lisp
+++ b/
src/code/target-alieneval.lisp
@@
-61,10
+61,6
@@
',alien-name
',alien-type))))))
',alien-name
',alien-type))))))
-(defmacro def-alien-variable (&rest rest)
- (deprecation-warning 'def-alien-variable 'define-alien-variable)
- `(define-alien-variable ,@rest))
-
;;; Do the actual work of DEFINE-ALIEN-VARIABLE.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun %define-alien-variable (lisp-name alien-name type)
;;; Do the actual work of DEFINE-ALIEN-VARIABLE.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun %define-alien-variable (lisp-name alien-name type)
@@
-446,7
+442,8
@@
allocated using ``malloc'', so it can be passed to foreign functions which use
(lambda ()
(alien-funcall
(extern-alien "free" (function (values) system-area-pointer))
(lambda ()
(alien-funcall
(extern-alien "free" (function (values) system-area-pointer))
- alien-sap)))
+ alien-sap))
+ :dont-save t)
alien))
(defun note-local-alien-type (info alien)
alien))
(defun note-local-alien-type (info alien)
@@
-463,6
+460,8
@@
allocated using ``malloc'', so it can be passed to foreign functions which use
(define-setf-expander local-alien (&whole whole info alien)
(let ((value (gensym))
(define-setf-expander local-alien (&whole whole info alien)
(let ((value (gensym))
+ (info-var (gensym))
+ (alloc-tmp (gensym))
(info (if (and (consp info)
(eq (car info) 'quote))
(second info)
(info (if (and (consp info)
(eq (car info) 'quote))
(second info)
@@
-473,8
+472,10
@@
allocated using ``malloc'', so it can be passed to foreign functions which use
(list value)
`(if (%local-alien-forced-to-memory-p ',info)
(%set-local-alien ',info ,alien ,value)
(list value)
`(if (%local-alien-forced-to-memory-p ',info)
(%set-local-alien ',info ,alien ,value)
- (setf ,alien
- (deport ,value ',(local-alien-info-type info))))
+ (let* ((,info-var ',(local-alien-info-type info))
+ (,alloc-tmp (deport-alloc ,value ,info-var)))
+ (maybe-with-pinned-objects (,alloc-tmp) (,(local-alien-info-type info))
+ (setf ,alien (deport ,alloc-tmp ,info-var)))))
whole)))
(defun %local-alien-forced-to-memory-p (info)
whole)))
(defun %local-alien-forced-to-memory-p (info)
@@
-534,28
+535,38
@@
allocated using ``malloc'', so it can be passed to foreign functions which use
\f
;;;; NATURALIZE, DEPORT, EXTRACT-ALIEN-VALUE, DEPOSIT-ALIEN-VALUE
\f
;;;; NATURALIZE, DEPORT, EXTRACT-ALIEN-VALUE, DEPOSIT-ALIEN-VALUE
+(defun coerce-to-interpreted-function (lambda-form)
+ (let (#!+sb-eval
+ (*evaluator-mode* :interpret))
+ (coerce lambda-form 'function)))
+
(defun naturalize (alien type)
(declare (type alien-type type))
(defun naturalize (alien type)
(declare (type alien-type type))
- (funcall (coerce (compute-naturalize-lambda type) 'function)
+ (funcall (coerce-to-interpreted-function (compute-naturalize-lambda type))
alien type))
(defun deport (value type)
(declare (type alien-type type))
alien type))
(defun deport (value type)
(declare (type alien-type type))
- (funcall (coerce (compute-deport-lambda type) 'function)
+ (funcall (coerce-to-interpreted-function (compute-deport-lambda type))
+ value type))
+
+(defun deport-alloc (value type)
+ (declare (type alien-type type))
+ (funcall (coerce-to-interpreted-function (compute-deport-alloc-lambda type))
value type))
(defun extract-alien-value (sap offset type)
(declare (type system-area-pointer sap)
(type unsigned-byte offset)
(type alien-type type))
value type))
(defun extract-alien-value (sap offset type)
(declare (type system-area-pointer sap)
(type unsigned-byte offset)
(type alien-type type))
- (funcall (coerce (compute-extract-lambda type) 'function)
+ (funcall (coerce-to-interpreted-function (compute-extract-lambda type))
sap offset type))
(defun deposit-alien-value (sap offset type value)
(declare (type system-area-pointer sap)
(type unsigned-byte offset)
(type alien-type type))
sap offset type))
(defun deposit-alien-value (sap offset type value)
(declare (type system-area-pointer sap)
(type unsigned-byte offset)
(type alien-type type))
- (funcall (coerce (compute-deposit-lambda type) 'function)
+ (funcall (coerce-to-interpreted-function (compute-deposit-lambda type))
sap offset type value))
\f
;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE
sap offset type value))
\f
;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE
@@
-713,10
+724,6
@@
allocated using ``malloc'', so it can be passed to foreign functions which use
(values ,@temps ,@(results))))
(values (alien-funcall ,lisp-name ,@(alien-args))
,@(results)))))))))
(values ,@temps ,@(results))))
(values (alien-funcall ,lisp-name ,@(alien-args))
,@(results)))))))))
-
-(defmacro def-alien-routine (&rest rest)
- (deprecation-warning 'def-alien-routine 'define-alien-routine)
- `(define-alien-routine ,@rest))
\f
(defun alien-typep (object type)
#!+sb-doc
\f
(defun alien-typep (object type)
#!+sb-doc
@@
-778,6
+785,7
@@
ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.")
(vector-push-extend
(alien-callback-lisp-trampoline wrapper function)
*alien-callback-trampolines*)
(vector-push-extend
(alien-callback-lisp-trampoline wrapper function)
*alien-callback-trampolines*)
+ ;; Assembler-wrapper is static, so sap-taking is safe.
(let ((sap (vector-sap assembler-wrapper)))
(push (cons sap (make-callback-info :specifier specifier
:function function
(let ((sap (vector-sap assembler-wrapper)))
(push (cons sap (make-callback-info :specifier specifier
:function function