foreign-array.lisp 10.5 KB
Newer Older
Liam Healy's avatar
Liam Healy committed
1
2
;; Foreign (C or C-compatible) arrays
;; Liam Healy 2008-12-28 10:44:22EST foreign-array.lisp
3
;; Time-stamp: <2013-11-23 09:45:23EST foreign-array.lisp>
4
;;
5
;; Copyright 2008, 2009, 2010, 2011, 2012, 2013 Liam M. Healy
6
7
8
9
10
11
12
13
14
15
16
17
18
19
;; Distributed under the terms of the GNU General Public License
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
Liam Healy's avatar
Liam Healy committed
20

21
(in-package :grid)
Liam Healy's avatar
Liam Healy committed
22

23
;;; A foreign-array is an array in foreign memory.  If the CL
24
25
26
;;; implementation supports static-vectors and it is single
;;; dimensional or linearization is :row-major, the same array will
;;; appear as a CL array in the slot 'cl-array.
27

Liam Healy's avatar
Liam Healy committed
28
29
30
31
;;;;****************************************************************************
;;;; Object and methods
;;;;****************************************************************************

32
(export '(foreign-array foreign-pointer dimensions 
33
	  cl-array metadata-slot
34
	  *print-contents* *print-foreign-array-readably*
35
	  make-foreign-array
36
	  make-fortran-array
37
	  ensure-foreign-array
38
	  make-foreign-array-from-pointer))
39

40
41
42
(eval-when (:compile-toplevel :load-toplevel :execute)
  (pushnew 'foreign-array *grid-types*))

Liam Healy's avatar
Liam Healy committed
43
(defclass foreign-array ()
44
  ((foreign-pointer :initarg :foreign-pointer :reader foreign-pointer)
Liam Healy's avatar
Liam Healy committed
45
46
   (dimensions :initarg :dimensions :reader dimensions)
   ;;(rank :initarg :rank :reader rank)
Liam Healy's avatar
Liam Healy committed
47
   (total-size :reader total-size)
48
   (element-type :initarg :element-type :reader element-type
Liam Healy's avatar
Liam Healy committed
49
		 :initform *default-element-type*)
50
   (affi :reader affi)
Liam Healy's avatar
Liam Healy committed
51
   (cl-array :reader cl-array :initform nil)
52
53
   (foreign-metadata
    :reader foreign-metadata :initarg :foreign-metadata :initform nil))
Liam Healy's avatar
Liam Healy committed
54
  (:documentation
55
   "Arrays that can be referenced by foreign functions."))
Liam Healy's avatar
Liam Healy committed
56

57
58
59
60
;;; Foreign complex arrays at present are only supported on
;;; static-vectors.  Work needs to be done to set elements in the case
;;; of non-static-vectors [[id:f6b82bef-3dd2-4371-aa0e-eda4c9b8b781]].

61
(defmethod initialize-instance :after
Liam Healy's avatar
Liam Healy committed
62
63
    ((object foreign-array)
     &key dimensions element-type foreign-pointer finalizer
64
     (linearization :row-major)		; :row-major or :column-major
Liam Healy's avatar
Liam Healy committed
65
     initial-element initial-contents)
66
67
  ;; For multidimensional arrays, initial-contents can be flat (unlike
  ;; make-array) or with the proper depth (as for make-array).
68
69
70
  (assert (member element-type *array-element-types* :test 'equal)
	  (element-type)
	  "Element type ~a not permitted." element-type)
71
72
73
  (assert (or (null dimensions) (and (listp dimensions) (every 'integerp dimensions)))
	  (dimensions)
	  "Dimensions must be a list of positive integers or nil; ~a is not acceptable." dimensions)
74
  (setf	(slot-value object 'total-size)
75
	(total-size-from-dimension dimensions)
76
77
78
79
	(slot-value object 'affi)
	(case linearization
	  (:column-major (affi:make-affi-cm dimensions))
	  (t (affi:make-affi dimensions)))
Liam Healy's avatar
Liam Healy committed
80
81
	;;(slot-value object 'rank) (length dimensions)
	)
82
  (unless foreign-pointer
83
    (let* ((ic (coerce-value (alexandria:flatten initial-contents) element-type))
84
85
86
	   (ict (if (eq linearization :column-major)
		    ;; transpose initial contents
		    (loop with map
87
			 = (affi::map-affi (affi:make-affi dimensions)
88
					   (affi object))
89
90
			 for i from 0 below (length ic)
			 collect (nth (funcall map i) ic))
91
92
93
		    ic))
	   (ivc (when initial-element
		  (coerce-value initial-element element-type))))
94
      (if (and (member :static-vectors *features*)
95
96
	       ;; Some implementations do not support complex element types as static vectors
	       #+(or ccl lispworks) (not (subtypep element-type 'complex))
97
98
99
100
101
	       (or (= 1 (length dimensions))
		   (eql linearization :row-major)))
	  ;; Make a CL image array if the implementation supports it and
	  ;; this is a vector (one dimensional) or multi-dimensional
	  ;; array in row-major order (e.g., C, not Fortran).
102
	  #+static-vectors
103
104
105
106
107
108
	  (let ((sv
		 (apply
		  'static-vectors:make-static-vector
		  (total-size object)
		  :element-type element-type
		  (append
109
		   (when initial-element (list :initial-element ivc))
110
111
112
113
114
115
116
117
118
119
		   (when initial-contents (list :initial-contents ict))))))
	    (tg:finalize object (lambda () (static-vectors:free-static-vector sv)))
	    (setf (slot-value object 'cl-array)
		  (if (= 1 (length dimensions))
		      sv
		      (make-array dimensions
				  :element-type element-type
				  :displaced-to sv))
		  (slot-value object 'foreign-pointer)
		  (static-vectors:static-vector-pointer sv)))
120
	  #-static-vectors nil
121
122
123
124
125
126
127
	  ;; Otherwise, just set up the foreign array.
	  (let ((fv
		 (apply
		  'cffi:foreign-alloc
		  (cl-cffi element-type)
		  :count (total-size object)
		  (append
128
		   (when (and initial-element (not (subtypep element-type 'complex)))
129
		     (list :initial-element ivc))
130
131
		   (when (and initial-contents (not (subtypep element-type 'complex)))
		     (list :initial-contents ict))))))
132
	    (setf (slot-value object 'foreign-pointer) fv)
133
	    ;; Set the complex initial-contents separately
134
	    (when (subtypep element-type 'complex)
135
136
	      (when initial-element
		(loop for index from 0 below (total-size object)
Liam M. Healy's avatar
Liam M. Healy committed
137
		   do (setf (aref* object index) ivc)))
138
139
140
	      (when initial-contents
		(loop for elt in ict 
		   for index from 0 below (total-size object)
Liam M. Healy's avatar
Liam M. Healy committed
141
		   do (setf (aref* object index) elt))))
142
	    (tg:finalize object (lambda () (cffi:foreign-free fv)))))))
143
144
145
146
  ;; If the foreign-pointer was supplied, a finalizer will not be
  ;; attached unless requested; the assumption is that the foreign
  ;; code will take care of freeing memory.
  (when (and foreign-pointer finalizer)	; a finalizer was requested
147
    (tg:finalize object (lambda () (cffi:foreign-free foreign-pointer)))))
Liam Healy's avatar
Liam Healy committed
148
149
150
151

(defparameter *print-contents* t
  "Print the contents of the foreign-array.")

152
153
154
(defparameter *print-foreign-array-readably* t
  "Print the contents of the foreign-array with the #m reader macro.")

Liam M. Healy's avatar
Liam M. Healy committed
155
156
;;;; Move these
(defgeneric print-grid-readably (object contents-writer stream)
157
  (:documentation "Print the grid readably. The contents-writer is a function that is called on the stream and writes the contents of the grid.")
Liam M. Healy's avatar
Liam M. Healy committed
158
159
160
161
162
  (:method ((object t) contents-writer stream)
    (declare (ignore object))
    (funcall contents-writer stream)))

(defmethod print-grid-readably ((object foreign-array) contents-writer stream)
163
164
  (format stream "#~@[~d~]m" (hashm-numeric-code (element-type object)))
  (funcall contents-writer stream))
Liam M. Healy's avatar
Liam M. Healy committed
165
166

(defmethod print-grid-readably ((object array) contents-writer stream)
167
168
  (format stream (if (= (length (dimensions object)) 2) "#2A" "#"))
  (funcall contents-writer stream))
Liam M. Healy's avatar
Liam M. Healy committed
169

Liam Healy's avatar
Liam Healy committed
170
(defmethod print-object ((object foreign-array) stream)
171
  (if (and *print-foreign-array-readably* *print-contents*)
172
      (antik::cl-readable-nf (antik::nf-grid object stream))
173
174
175
176
177
178
      (print-unreadable-object (object stream :type t) 
	(if *print-contents*
	    (if (slot-boundp object 'foreign-pointer)
		(princ (contents object) stream)
		(princ "with no pointer" stream))
	    (format stream "dimensions ~a" (dimensions object))))))
Liam Healy's avatar
Liam Healy committed
179

180
181
182
183
(defmacro metadata-slot (object name)
  "Access a slot in the foreign-metadata."
  `(getf (slot-value ,object 'foreign-metadata) ,name))

184
185
(defmethod make-load-form ((object foreign-array) &optional env)
  (declare (ignore env))
Liam M. Healy's avatar
Liam M. Healy committed
186
  (check-initial-contents (contents object))
187
188
189
190
  `(make-grid
    '((foreign-array ,@(dimensions object)) ,(element-type object))
    :initial-contents ',(contents object)))

191
192
(push '(1 . foreign-array) *hashm-grid-type-alist*)

193
194
195
196
197
;;;;****************************************************************************
;;;; Make foreign-arrays
;;;;****************************************************************************

(defun make-foreign-array (element-type &rest keys &key dimensions &allow-other-keys)
198
  "Make a foreign array with the given element type,
199
200
201
202
203
   :dimensions, and :initial-contents, :initial-element or :data."
  (when (subtypep element-type 'foreign-array)
    (error "Can't take a class name here anymore, sorry."))
  (apply
   'make-grid
204
   (make-specification 'foreign-array dimensions element-type)
205
206
   keys))

207
208
209
210
211
212
213
214
215
216
(defun make-fortran-array (element-type &rest keys)
  "Make an array in column-major order with the given element type,
   :dimensions, and :initial-contents, :initial-element or :data."
  (apply 'make-instance
	 'foreign-array
	 :element-type element-type
	 :linearization :column-major
	 :finalizer t			; if we're making it, we should have a finalizer
	 keys))

217
(defun ensure-foreign-array
218
219
220
221
222
223
224
    (object
	&optional
	(dimensions *default-dimensions*)
      (element-type *default-element-type*)
      initial-element)
  "If object is not a foreign array, make and return a foreign array
   with the dimensions and element-type.  If object is a
225
   foreign array, it is returned."
226
227
  (if (typep object 'foreign-array)
      object
228
229
230
      (if initial-element
	  (make-foreign-array
	   element-type :dimensions dimensions :initial-element initial-element)
231
	  (make-foreign-array element-type :dimensions dimensions))))
232

233
234
235
236
237
238
239
240
(defun make-foreign-array-from-pointer
    (pointer dimensions element-type &optional finalize)
  "Given a foreign pointer to an array, make a Lisp object of 
   class 'foreign-array that references that.  This will never
   make a static-vector.  If finalize is true, than the array
   memory will be freed when this object is garbage collected;
   otherwise it is presumed that the foreign code will handle
   that job."
241
242
243
244
245
246
  (make-instance
   (data-class-name (length dimensions) element-type)
   :foreign-pointer pointer
   :dimensions dimensions
   :element-type element-type
   :finalizer finalize))
247

248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
#|
;;; Establish a restart that takes cl-array if the calling form is
;;; looking for an array and gets a foreign-array.
(defmacro use-cl-array (&body body)
  "Use the cl-array on foreign-arrays."
  `(handler-bind
       ((type-error
	 (lambda (c)
	   (let ((obj (type-error-datum c)))
	     (when (and (typep obj 'foreign-array)
			(subtypep (type-error-expected-type c) 'array)
			(cl-array obj))
	       (use-value (cl-array obj)))))))
     ,@body))
|#

264
265
266
267
268
#|
(defparameter *test-fv* 
  (make-instance 'foreign-array :dimensions '(3)
		 :element-type 'double-float
		 :initial-contents '(1.0d0 2.0d0 3.0d0)))
Liam Healy's avatar
Liam Healy committed
269

270
(make-grid-data 'foreign-array '(2 2) '(double-float) :initial-element pi)
271
|#