foreign-friendly.lisp 7.2 KB
Newer Older
1
;; Use the foreign-friendly arrays package.
2
;; Liam Healy 2008-03-22 15:40:08EDT
Liam Healy's avatar
Liam Healy committed
3
;; Time-stamp: <2008-12-27 10:23:27EST foreign-friendly.lisp>
lhealy's avatar
lhealy committed
4
;; $Id$
5

6
;;; Foreign-friendly arrays (original implementation by Tamas Papp)
7
;;; http://www.princeton.edu/~tpapp/software.html
8
9
;;; The replacements here don't do coercions or checks
;;; on type as they are unnecessary, and handle complex types.
10
11
12
13

(in-package :gsl)

;;;;****************************************************************************
14
;;;; Make arrays for possible foreign use 
15
16
;;;;****************************************************************************

17
18
19
20
21
(defun make-ffa
    (element-type
     &key dimensions (initial-element nil initial-element-p)
     (initial-contents nil initial-contents-p)
     &allow-other-keys)
22
  "Make an array of one or two dimensions for possible use in foreign code.
23
24
   Syntax is similar to make-array, but note that element-type
   is mandatory and limited to certain types."
25
  (assert (member element-type *array-element-types* :test 'equal)
26
27
	  (element-type)
	  "Specified element-type must be one of *array-element-types*.")
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
  (let* ((initial-matrix (listp (first initial-contents)))
	 (complex-initial-real
	  (and initial-contents-p
	       (subtypep element-type 'complex)
	       (typep
		(if initial-matrix
		    (caar initial-contents)
		    (first initial-contents))
		'real))))
    (unless dimensions
      (if initial-contents-p
	  (setf dimensions
		(if initial-matrix
		    ;; matrix
		    (list (length initial-contents)
			  (ceiling (length (first initial-contents))
				   (if complex-initial-real 2 1)))
		    ;; vector
		    (ceiling (length initial-contents)
			     (if complex-initial-real 2 1))))
	  (error "dimensions must be specified if contents are not")))
    (when (and initial-matrix initial-contents-p)
      ;; flatten matrix spec
Liam Healy's avatar
Liam Healy committed
51
      (setf initial-contents (apply #'append initial-contents)))
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
    (when complex-initial-real
      (setf initial-contents (list-complex-from-real initial-contents)))
    (apply 'make-ffa-1d
	   dimensions element-type
	   (append
	    (when initial-contents-p
		     (list :initial-contents initial-contents))
	    (when initial-element-p
		     (list :initial-element initial-element))))))

(defun list-complex-from-real (list)
  "Collect a list of complex numbers from real components."
  (assert (evenp (length list)) (list) 
	  "Cannot collect reals into complex from an odd number of reals.")
  (loop for (re im) on list by #'cddr collect (complex re im)))
Liam Healy's avatar
Liam Healy committed
67

68
(defun make-ffa-1d (dimensions element-type &key
Liam Healy's avatar
Liam Healy committed
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
		 (initial-element 0 initial-element-p)
		 (initial-contents nil initial-contents-p))
  "Make an array that is either one-dimensional or displaced to a
   one-dimensional array.  Array is filled with initial-element or
   initial-contents, coerced to the given type."
  ;; element-type is a type spec in CL form
  (assert (or (atom dimensions) (and (listp dimensions) (car dimensions))))
  (let* ((dimensions (if (atom dimensions) (list dimensions) dimensions))
	 (length (reduce #'* dimensions))
	 (array (cond
		  ((and initial-element-p initial-contents-p)
		   (error "you can't supply both initial-element and ~
                           initial-contents"))
		  ;; initial element given
		  (initial-element-p
		   (make-array length :element-type element-type
			       :initial-element (coerce initial-element
							element-type)))
		  ;; contents given, copy or coerce
		  (initial-contents-p
89
90
91
		   (when (listp (first initial-contents))
		     ;; flatten list for matrices
		     (setf initial-contents (apply 'append initial-contents)))
Liam Healy's avatar
Liam Healy committed
92
93
94
95
96
97
98
99
100
101
102
		   (assert (= (length initial-contents) length))
		   (if (typep initial-contents (list 'vector element-type))
		       (copy-seq initial-contents)
		       (map (list 'vector element-type)
			    (lambda (x) (coerce x element-type)) initial-contents)))
		  ;; neither
		  (t (make-array length :element-type element-type)))))
    (if (cdr dimensions)
	(make-array dimensions :element-type element-type 
		    :displaced-to array)
	array)))
103

Liam Healy's avatar
Liam Healy committed
104
105
106
107
108
109
;;;;****************************************************************************
;;;; Protect native pointers (supercedes "pointer management" below for native)
;;;;****************************************************************************

;;; To be called by a defmfun expander
#+sbcl
110
(defun native-pointer-protect (array-symbols body)
Liam Healy's avatar
Liam Healy committed
111
112
  "Wrap the body with a form that obtains the native pointer
   and protects it during execution of the body."
113
114
115
116
  ;; http://www.sbcl.org/manual/Calling-Lisp-From-C.html
  `(sb-sys:with-pinned-objects
       ,(mapcar (lambda (s) `(original-array ,s)) array-symbols)
     ,body))
Liam Healy's avatar
Liam Healy committed
117
118

#+sbcl
119
(defun c-pointer (marray)
Liam Healy's avatar
Liam Healy committed
120
121
  "The pointer to the C array."
  (cffi:inc-pointer
122
   (sb-sys:vector-sap (original-array marray)) (offset marray)))
Liam Healy's avatar
Liam Healy committed
123

124
125
126
127
;;;;****************************************************************************
;;;; Pointer management
;;;;****************************************************************************

Liam Healy's avatar
Liam Healy committed
128
129
130
131
132
133
134
135
136
137
138
139
140
#+native
(defmacro with-pointer-to-array ((array pointer cffi-type length)
				 &body body)
  (assert (symbolp pointer))
  (once-only (array cffi-type)
    (with-unique-names (original-array index-offset)
      `(multiple-value-bind (,original-array ,index-offset)
	   (find-original-array ,array)
	 (pin-to-pointer (,original-array ,pointer ,cffi-type
					  ,length ,index-offset)
	   ,@body)))))


141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
#+native
(defmacro with-pointer-to-array ((array pointer cffi-type length)
				 &body body)
  (assert (symbolp pointer))
  (once-only (array cffi-type)
    (with-unique-names (original-array index-offset)
      `(multiple-value-bind (,original-array ,index-offset)
	   (find-original-array ,array)
	 (pin-to-pointer (,original-array ,pointer ,cffi-type
					  ,length ,index-offset)
	   ,@body)))))

#-native
(defmacro with-pointer-to-array ((array pointer cffi-type length)
				 &body body)
  (assert (symbolp pointer))
  (once-only (array cffi-type)
    (with-unique-names (original-array index-offset)
      `(multiple-value-bind (,original-array ,index-offset)
	   (find-original-array ,array)
	 (cffi:with-foreign-object (,pointer ,cffi-type ,length)
	   ,@body)))))

#+sbcl
(defmacro pin-to-pointer ((array pointer cffi-type length index-offset)
			  &body body)
  (declare (ignorable length))
  "Use SBCL's sb-sys:with-pinned-objects and sb-sys:vector-sap for
mapping an array to a memory location.  NOTE: checking that cffi-type
matches the type of the array is the responsibility of the user of
this macro.  The size of the array is checked.  The array is required
to have rank one."
  (once-only (array)
    `(sb-sys:with-pinned-objects (,array)
       ;;(assert (<= (+ ,index-offset ,length) (length ,array)))
       (let ((,pointer
	      (cffi:inc-pointer
	       (sb-sys:vector-sap ,array)
	       (* ,index-offset (cffi:foreign-type-size ,cffi-type)))))
	 ,@body))))

(defun find-original-array (array)
  "Find the original parent of a displaced array, return this and the
sum of displaced index offsets."
  (let ((sum-of-offsets 0))
    (tagbody
     check-displacement
       (multiple-value-bind (displaced-to displaced-index-offset)
	   (array-displacement array)
	 (when displaced-to
	   (setf array displaced-to)
	   (incf sum-of-offsets displaced-index-offset)
	   (go check-displacement))))
    (values array sum-of-offsets)))