[327bf8]: contrib / cl-simd / ecl-sse-core.lisp Maximize Restore History

Download this file

ecl-sse-core.lisp    316 lines (288 with data), 15.6 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
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
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
;;; -*- mode: Lisp; indent-tabs-mode: nil; -*-
;;;
;;; Copyright (c) 2010, Alexander Gavrilov (angavrilov@gmail.com)
;;;
;;; This file defines macros for wrapping C-level SSE intrinsics.
;;;
(in-package #:SSE)
;;; The compound SSE pack type
(deftype sse-pack (&optional item)
(ecase item
(* 'ext:sse-pack)
((single-float float) 'float-sse-pack)
(double-float 'double-sse-pack)
(integer 'int-sse-pack)))
;;; Helper macros and functions
(defmacro typename-case (value &body clauses)
"Syntax: (case value &body clauses)"
`(cond ,@(mapcar (lambda (clause)
`((subtypep ,value ',(first clause))
,@(rest clause)))
clauses)
(t (error "Unsupported type name: ~S" ,value))))
(defun foreign-type-of (lt)
(typename-case lt
(nil :object)
(int-sse-pack :int-sse-pack)
(float-sse-pack :float-sse-pack)
(double-sse-pack :double-sse-pack)
(boolean :bool)
(single-float :float)
(double-float :double)
(fixnum :fixnum)
#+uint32-t
(ext:integer32 :int32-t)
#+uint32-t
(ext:byte32 :uint32-t)
#+uint64-t
(ext:integer64 :int64-t)
#+uint64-t
(ext:byte64 :uint64-t)
(integer :fixnum)))
(defun pointer-c-type-of (lt)
(typename-case lt
(nil "void")
(int-sse-pack "__m128i")
(float-sse-pack "float")
(double-sse-pack "double")))
;; Accept any real values for floating-point arguments:
(defun declaim-arg-type-of (lt)
(typename-case lt
((or single-float double-float) 'real)
(ext:sse-pack 'ext:sse-pack)
(fixnum 'fixnum)
(t lt)))
(defun inline-arg-type-of (lt)
(typename-case lt
((or single-float double-float) 'c::fixnum-float)
(fixnum 'fixnum)
(t lt)))
;; Constant expansion
(defun expand-constant (form env &optional chgp)
(let* ((mform (macroexpand form env))
(cform (cond ((and (symbolp mform) (constantp mform))
(symbol-value mform))
(t mform))))
(values cform (or chgp (not (eql cform form))))))
;; Macro helpers
(defun make-arg-name (index)
(intern (format nil "ARG~A" index)))
(defun make-arg-nums (lst)
(loop for i from 0 below (length lst) collect i))
(defun wrap-ret-arg (core ret-type &optional ret-arg)
(cond ((eq ret-type nil)
(format nil "(~A,Cnil)" core))
(ret-arg
(format nil "@~36R;(~A,#~36R)" ret-arg core ret-arg))
(t core)))
;; Constant generation
(defun make-pack-of-bin (bin-value &key (as 'int-sse-pack))
(let* ((all (loop for i from 0 to 15
for v = bin-value then (ash v -8)
collect (logand v 255)))
(pack (ext:vector-to-sse-pack
(make-array 16 :element-type '(unsigned-byte 8) :initial-contents all))))
(if (eq as 'int-sse-pack)
pack
`(the ,as ,(ext:sse-pack-as-elt-type
pack (ecase as
(EXT:FLOAT-SSE-PACK 'single-float)
(EXT:DOUBLE-SSE-PACK 'double-float)))))))
(defmacro def-inline (name mode arg-types ret-type call-str &rest flags)
`(eval-when (:compile-toplevel :load-toplevel)
(c::def-inline ',name ',mode ',arg-types ',ret-type ,call-str ,@flags)))
(defmacro def-intrinsic (name arg-types ret-type c-name
&key (export t) ret-arg reorder-args immediate-args defun-body)
"Defines and exports an SSE intrinsic function with matching open-coding rules."
(let* ((anums (make-arg-nums arg-types))
(asyms (mapcar #'make-arg-name anums))
(aftypes (mapcar #'foreign-type-of arg-types))
(rftype (foreign-type-of ret-type))
(call-anums (if reorder-args (reverse anums) anums))
(call-str (wrap-ret-arg (format nil "~A(~{#~36R~^,~})" c-name call-anums) ret-type ret-arg)))
`(progn
,(if export `(export ',name))
,@(if immediate-args ; Generate a constantness verifier macro
`((define-compiler-macro ,name (&whole whole &environment env ,@asyms &aux chgp)
,@(loop for (arg type) in immediate-args
collect `(let ((oldv ,arg))
(multiple-value-setq (,arg chgp) (expand-constant oldv env chgp))
(unless (typep ,arg ',type)
(c::cmperr "In call to ~A: Argument ~S~@[ = ~S~] is not a constant of type ~A"
',name oldv (unless (eql oldv ,arg) ,arg) ',type))))
(if chgp (list ',name ,@asyms) whole))))
(proclaim '(ftype (function ,(mapcar #'declaim-arg-type-of arg-types) ,(or ret-type 'null)) ,name))
,@(if (null immediate-args)
`((defun ,name ,asyms
(declare (optimize (speed 0) (debug 0) (safety 1)))
(ffi:c-inline ,asyms ,aftypes ,rftype ,(or defun-body call-str) :one-liner t))))
(def-inline ,name :always ,(mapcar #'inline-arg-type-of arg-types) ,rftype
,call-str :inline-or-warn t))))
(defmacro def-unary-intrinsic (name ret-type insn cost c-name
&key (arg-type ret-type) partial result-size immediate-arg)
(declare (ignore insn cost partial result-size))
`(def-intrinsic ,name (,arg-type ,@(if immediate-arg (list immediate-arg)))
,ret-type ,c-name :immediate-args ,(if immediate-arg `((arg1 ,immediate-arg)))))
(defmacro def-cvt-to-int32-intrinsic (name ret-type insn cost c-name
&key (arg-type ret-type) partial immediate-arg)
(declare (ignore insn cost partial))
(assert (subtypep ret-type '(signed-byte 32)))
`(def-intrinsic ,name (,arg-type ,@(if immediate-arg (list immediate-arg)))
,ret-type ,c-name :immediate-args ,(if immediate-arg `((arg1 ,immediate-arg)))))
(defmacro def-binary-intrinsic (name ret-type insn cost c-name
&key (x-type ret-type) (y-type ret-type)
commutative tags immediate-arg)
(declare (ignore insn cost commutative tags))
`(def-intrinsic ,name (,x-type ,y-type ,@(if immediate-arg (list immediate-arg)))
,ret-type ,c-name :immediate-args ,(if immediate-arg `((arg2 ,immediate-arg)))))
(defmacro def-sse-int-intrinsic (name int-type ret-type insn cost c-name
&key (arg-type ret-type) immediate-arg make-temporary defun-body)
(declare (ignore insn cost make-temporary))
`(def-intrinsic ,name (,arg-type ,int-type ,@(if immediate-arg (list immediate-arg)))
,ret-type ,c-name :immediate-args ,(if immediate-arg `((arg2 ,immediate-arg)))
:defun-body ,defun-body))
(defmacro def-comparison-intrinsic (name arg-type insn cost c-name &key commutative tags)
(declare (ignore insn cost commutative tags))
`(def-intrinsic ,name (,arg-type ,arg-type) boolean ,c-name))
(defmacro %def-aref-intrinsic (tag val-type c-type reader writer &key (aux-args "") (bsize 16))
"Defines and exports macros and functios that implement vectorized array access."
(let* ((rftype (foreign-type-of val-type))
(aref-name (intern (format nil "AREF-~A" tag) *package*))
(rm-aref-name (intern (format nil "ROW-MAJOR-AREF-~A" tag) *package*))
(rm-aset-name (intern (format nil "ROW-MAJOR-ASET-~A" tag) *package*))
(known-elt-types '((single-float "sf")
(double-float "df")
(ext:byte8 "b8")
(ext:integer8 "i8")
#+uint16-t (ext:byte16 "b16")
#+uint16-t (ext:integer16 "i16")
#+uint32-t (ext:byte32 "b32")
#+uint32-t (ext:integer32 "i32")
#+uint64-t (ext:byte64 "b64")
#+uint64-t (ext:integer64 "i64"))))
(flet ((fmtr (ptr-fmt &rest ptr-args)
(wrap-ret-arg (format nil "~A((~A*)~?~A)"
reader c-type ptr-fmt ptr-args aux-args)
val-type))
(fmtw (ptr-fmt &rest ptr-args)
(wrap-ret-arg (format nil "~A((~A*)~?,#2)"
writer c-type ptr-fmt ptr-args)
val-type 2)))
`(progn
(export ',aref-name)
(export ',rm-aref-name)
(defmacro ,aref-name (array &rest indexes)
(let ((varr (gensym "ARR")))
`(let ((,varr ,array))
(declare (:read-only ,varr))
(,',rm-aref-name ,varr (array-row-major-index ,varr ,@indexes)))))
(proclaim '(ftype (function (array fixnum) ,(or val-type 'null)) ,rm-aref-name))
(defun ,rm-aref-name (array index)
(declare (optimize (speed 0) (debug 0) (safety 2)))
(ffi:c-inline (array index) (:object :int) ,rftype
,(fmtr "ecl_row_major_ptr(#0,#1,~A)" bsize)
:one-liner t))
;; AREF
(def-inline ,rm-aref-name :always (t t) ,rftype
,(fmtr "ecl_row_major_ptr(#0,fixint(#1),~A)" bsize)
:inline-or-warn t)
(def-inline ,rm-aref-name :always (t fixnum) ,rftype
,(fmtr "ecl_row_major_ptr(#0,#1,~A)" bsize))
;; AREF unsafe
,@(mapcar (lambda (spec)
`(def-inline ,rm-aref-name :unsafe ((array ,(first spec)) fixnum) ,rftype
,(fmtr "(&(#0)->array.self.~A[#1])" (second spec))))
known-elt-types)
,@(if writer
`((define-setf-expander ,aref-name (array &rest indexes)
(let ((varr (gensym)) (vidx (gensym)) (vval (gensym)))
(values (list varr vidx)
(list array `(array-row-major-index ,varr ,@indexes))
(list vval)
`(,',rm-aset-name ,varr ,vidx ,vval) `(,',rm-aref-name ,varr ,vidx))))
(proclaim '(ftype (function (array fixnum ,(declaim-arg-type-of val-type)) ,val-type) ,rm-aset-name))
(defun ,rm-aset-name (array index value)
(declare (optimize (speed 0) (debug 0) (safety 2)))
(prog1 value
(ffi:c-inline (array index value) (:object :int ,rftype) :void
,(fmtw "ecl_row_major_ptr(#0,#1,~A)" bsize)
:one-liner t)))
(defsetf ,rm-aref-name ,rm-aset-name)
;; ASET
(def-inline ,rm-aset-name :always (t t ,val-type) ,rftype
,(fmtw "ecl_row_major_ptr(#0,fixint(#1),~A)" bsize)
:inline-or-warn t)
(def-inline ,rm-aset-name :always (t fixnum ,val-type) ,rftype
,(fmtw "ecl_row_major_ptr(#0,#1,~A)" bsize))
;; ASET unsafe
,@(mapcar (lambda (spec)
`(def-inline ,rm-aset-name :unsafe ((array ,(first spec)) fixnum ,val-type) ,rftype
,(fmtw "(&(#0)->array.self.~A[#1])" (second spec))))
known-elt-types)))))))
(defmacro def-aref-intrinsic (tag val-type reader-fun writer-fun &key (ref-size 16))
`(%def-aref-intrinsic ,tag ,val-type ,(pointer-c-type-of val-type)
,(get reader-fun 'c-function-name) ,(get writer-fun 'c-function-name)
:bsize ,ref-size
:aux-args ,(get reader-fun 'c-call-aux-args)))
(defmacro def-mem-intrinsic (name c-type ret-type c-name &key (public t)
prefix-args (prefix-fmt "~@{#~36R,~}")
postfix-args (postfix-fmt "~@{,#~36R~}" pf-p) ret-arg)
"Defines and exports an SSE memory access intrinsic function with matching open-coding rules."
(let* ((anums (make-arg-nums (append prefix-args postfix-args)))
(asyms (mapcar #'make-arg-name anums))
(prefix-nums (subseq anums 0 (length prefix-args)))
(postfix-nums (mapcar #'1+ (subseq anums (length prefix-args))))
(prefix-syms (subseq asyms 0 (length prefix-args)))
(postfix-syms (subseq asyms (length prefix-args)))
(prefix-itypes (mapcar #'inline-arg-type-of prefix-args))
(postfix-itypes (mapcar #'inline-arg-type-of postfix-args))
(rftype (foreign-type-of ret-type))
(ptr-idx (length prefix-args))
(offset-idx (+ ptr-idx 1 (length postfix-args))))
(flet ((fmt (ptr-text)
(wrap-ret-arg (format nil "~A(~?(~A*)~?~?)"
c-name prefix-fmt prefix-nums
c-type ptr-text (list ptr-idx offset-idx)
postfix-fmt postfix-nums)
ret-type ret-arg)))
`(progn
,(when public `(export ',name))
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (get ',name 'c-function-name) ,c-name)
,(if (and pf-p (null postfix-args))
`(setf (get ',name 'c-call-aux-args) ,postfix-fmt)))
(proclaim '(ftype (function (,@(mapcar #'declaim-arg-type-of prefix-args) si:foreign-data
,@(mapcar #'declaim-arg-type-of postfix-args) &optional fixnum) ,ret-type) ,name))
(defun ,name (,@prefix-syms ptr ,@postfix-syms &optional (offset 0))
(declare (optimize (speed 0) (debug 0) (safety 1)))
(ffi:c-inline (,@prefix-syms ptr ,@postfix-syms offset)
(,@(mapcar #'foreign-type-of prefix-args) :pointer-void
,@(mapcar #'foreign-type-of postfix-args) :int) ,rftype
,(fmt "(((char*)#~A) + #~A)")
:one-liner t))
(def-inline ,name :always (,@prefix-itypes t ,@postfix-itypes) ,rftype
,(fmt "ecl_to_pointer(#~A)")
:inline-or-warn t)
(def-inline ,name :always (,@prefix-itypes t ,@postfix-itypes t) ,rftype
,(fmt "(((char*)ecl_to_pointer(#~A)) + fixint(#~A))"))
(def-inline ,name :always (,@prefix-itypes t ,@postfix-itypes fixnum) ,rftype
,(fmt "(((char*)ecl_to_pointer(#~A)) + #~A)"))
(def-inline ,name :unsafe (,@prefix-itypes si:foreign-data ,@postfix-itypes) ,rftype
,(fmt "(#~A)->foreign.data"))
(def-inline ,name :unsafe (,@prefix-itypes si:foreign-data ,@postfix-itypes t) ,rftype
,(fmt "(((char*)(#~A)->foreign.data) + fix(#~A))"))
(def-inline ,name :unsafe (,@prefix-itypes si:foreign-data ,@postfix-itypes fixnum) ,rftype
,(fmt "(((char*)(#~A)->foreign.data) + #~A)"))))))
(defmacro def-load-intrinsic (name ret-type insn c-name &key register-arg tags size postfix-fmt)
(declare (ignore insn tags size))
`(def-mem-intrinsic ,name ,(pointer-c-type-of ret-type) ,ret-type ,c-name
:prefix-args ,(if register-arg (list ret-type))
:postfix-fmt ,(or postfix-fmt "")))
(defmacro def-store-intrinsic (name ret-type insn c-name &key setf-name)
(declare (ignore insn))
`(progn
(def-mem-intrinsic ,name ,(pointer-c-type-of ret-type) ,ret-type ,c-name
:public ,(not setf-name) :postfix-args (,ret-type) :ret-arg 1)
,(if setf-name
`(defsetf ,setf-name (pointer &optional (offset 0)) (value)
`(,',name ,pointer ,value ,offset)))))