Coverage report: /home/ellis/comp/core/lib/obj/tensor/class.lisp

Kind	Covered	All	%
expression	0	209	0.0
branch	0	20	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; class.lisp --- Tensor Classes

2

3

;;

4

5

;;; Code:

6

(in-package :obj/tensor)

7

8

;;; Tensor Classes

9

;;;; Numeric

10

(defclass numeric-tensor (standard-tensor) ())

11

;; (deft t.field-type (sym numeric-tensor) ()

12

;; 'number)

13

(defclass real-numeric-tensor (numeric-tensor) ())

14

;; (deft t.field-type (sym real-numeric-tensor) ()

15

;; 'real)

16

;; (deft t.realified-type (sym real-numeric-tensor) ()

17

;; sym)

18

19

(defclass rational-tensor (real-numeric-tensor) ())

20

;; (deft t.field-type (sym rational-tensor) ()

21

;; 'rational)

22

23

(defclass fixnum-tensor (real-numeric-tensor) ())

24

;; (deft t.field-type (sym fixnum-tensor) () 'fixnum)

25

26

(defclass octet-tensor (real-numeric-tensor) ())

27

;; (deft t.field-type (sym octet-tensor) () '(unsigned-byte 8))

28

29

(defclass boolean-tensor (real-numeric-tensor) ())

30

;; (deft t.field-type (sym boolean-tensor) () '(mod 2))

31

32

(defclass blas-numeric-tensor (numeric-tensor) ())

33

34

(defclass real-blas-tensor (real-numeric-tensor blas-numeric-tensor) ())

35

36

(defmethod print-element ((tensor real-blas-tensor)

37

element stream)

38

(format stream "~,4,-2,,,,'Eg" element))

39

40

(defclass real-tensor (real-blas-tensor) ())

41

;; (deft t.field-type (sym real-tensor) () 'double-float)

42

;; (deft t.complexified-type (sym real-tensor) () 'complex-tensor)

43

44

(defclass sreal-tensor (real-blas-tensor) ())

45

;; (deft t.field-type (sym sreal-tensor) () 'single-float)

46

;; (deft t.complexified-type (sym sreal-tensor) () 'scomplex-tensor)

47

48

(defclass complex-numeric-tensor (numeric-tensor) ())

49

;; (deft t.field-type (sym complex-numeric-tensor) () 'complex)

50

;; (deft t.complexified-type (sym complex-numeric-tensor) () sym)

51

52

(defclass complex-blas-tensor (complex-numeric-tensor blas-numeric-tensor) ())

53

54

(defmethod store-size ((tensor complex-blas-tensor))

55

(floor (/ (length (store tensor)) 2)))

56

57

(defmethod print-element ((tensor complex-blas-tensor)

58

element stream)

59

(let ((realpart (realpart element))

60

(imagpart (imagpart element)))

61

(if (not (zerop imagpart))

62

         (format stream "~,4,-2,,,,'Eg ~a ~,4,-2,,,,'Egi"  realpart (if (>= imagpart 0) #\+ #\-) (abs imagpart))

63

(format stream "~,4,-2,,,,'Eg" realpart))))

64

65

(defclass complex-tensor (complex-blas-tensor) ())

66

;; (deft t.field-type (sym complex-tensor) () '(complex double-float))

67

;; (deft t.realified-type (sym complex-tensor) () 'real-tensor)

68

69

(defclass scomplex-tensor (complex-blas-tensor) ())

70

;; (deft t.field-type (sym scomplex-tensor) () '(complex single-float))

71

;; (deft t.realified-type (sym scomplex-tensor) () 'sreal-tensor)

72

73

;;;; Sparse

74

(defclass real-coordinate-sparse-tensor (coordinate-sparse-tensor) ())

75

;; (deft t.field-type (sym real-coordinate-sparse-tensor) () 'double-float)

76

77

(defclass real-compressed-sparse-matrix (compressed-sparse-matrix) ())

78

;; (deft t.field-type (sym real-compressed-sparse-matrix) () 'double-float)

79

80

;;; Coordinate Sparse

81

(defclass coordinate-sparse-tensor (sparse-tensor)

82

((head :initarg :head :initform 0 :reader head :type index-type

83

:documentation "Head for the store's accessor.")

84

(strides :initarg :strides :type index-store-vector

85

:documentation "Strides for accesing elements of the tensor.")))

86

87

;; (deft t.sparse-fill sparse-tensor (sym)

88

;; `(t.fid+ (t.field-type ,sym)))

89

90

;; (deft t.store-allocator coordinate-sparse-tensor (sym size &optional nz)

91

;; (with-gensyms (size-sym)

92

 ;;     `(let ((,size-sym (or ,nz (min (max 16 (ceiling (/ ,size *default-sparsity*))) *max-sparse-size*))))

93

;; (make-hash-table :size ,size-sym))))

94

95

;; (deft t.store-ref coordinate-sparse-tensor (sym store &rest idx)

96

;; (assert (null (cdr idx)) nil "given more than one index for hashtable.")

97

;; `(the ,(field-type sym) (gethash ,(car idx) ,store (t/sparse-fill ,sym))))

98

99

;; (deft t.store-set coordinate-sparse-tensor (sym value store &rest idx)

100

;; (assert (null (cdr idx)) nil "given more than one index for hashtable.")

101

;; (with-gensyms (val)

102

;; `(let-typed ((,val ,value :type ,(field-type sym)))

103

;; (unless (t/f= ,(field-type sym) ,val (t/fid+ ,(field-type sym)))

104

;; (setf (gethash ,(car idx) ,store) (the ,(field-type sym) ,value))))))

105

106

;; (deft t.store-type coordinate-sparse-tensor (sym &optional (size '*))

107

;; 'hash-table)

108

109

;; (deft t.store-size coordinate-sparse-tensor (sym ele)

110

;; `(hash-table-count ,ele))

111

112

;; (deft t.store-type coordinate-sparse-tensor (sym &optional (size '*))

113

;; 'hash-table)

114

;;

115

(defmethod ref ((tensor coordinate-sparse-tensor) &rest subscripts)

116

(let ((clname (class-name (class-of tensor))))

117

;; (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)

118

(compile-and-eval

119

`(defmethod ref ((tensor ,clname) &rest subscripts)

120

(let ((subs (if (numberp (car subscripts)) subscripts (car subscripts))))

121

(t.store-ref ,clname (store tensor) (store-indexing subs tensor)))))

122

(apply #'ref (cons tensor subscripts))))

123

124

(defmethod (setf ref) (value (tensor coordinate-sparse-tensor) &rest subscripts)

125

(let ((clname (class-name (class-of tensor))))

126

;; (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)

127

(compile-and-eval

128

`(defmethod (setf ref) (value (tensor ,clname) &rest subscripts)

129

(let* ((subs (if (numberp (car subscripts)) subscripts (car subscripts)))

130

(idx (store-indexing subs tensor))

131

(sto (store tensor)))

132

(t.store-set ,clname (t/coerce ,(field-type clname) value) sto idx)

133

(t.store-ref ,clname sto idx))))

134

(setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value)))

135

136

;;; Compressed Sparse

137

(defclass compressed-sparse-matrix (sparse-tensor)

138

((transposed :initform nil :initarg :transposed :reader transposed :type boolean

139

                :documentation "If NIL the matrix is in CSC, else if T, then matrix is CSR.")

140

(neighbour-start :initarg :neighbour-start :reader neighbour-start :type index-store-vector

141

:documentation "Start index for ids and store.")

142

(neighbour-id :initarg :neighbour-id :reader neighbour-id :type index-store-vector

143

:documentation "Row id.")))

144

145

(declaim (ftype (function (compressed-sparse-matrix) index-store-vector) neighbour-start neighbour-id))

146

147

(defun compressed-sparse-indexing (subs tensor)

148

(declare (type compressed-sparse-matrix tensor)

149

(type (or index-store-vector cons) subs))

150

(lety ((row 0 :type index-type)

151

(col 0 :type index-type))

152

(etypecase subs

153

(cons

154

(assert (null (cddr subs)) nil 'tensor-index-rank-mismatch)

155

(setf row (the index-type (car subs))

156

col (the index-type (cadr subs))))

157

(index-store-vector

158

(assert (= (length subs) 2) nil 'tensor-index-rank-mismatch)

159

(setf row (the index-type (aref subs 0))

160

col (the index-type (aref subs 1)))))

161

(when (transposed tensor)

162

(rotatef row col))

163

(lety* ((nst (neighbour-start tensor) :type index-store-vector)

164

(nid (neighbour-id tensor) :type index-store-vector)

165

(lb (aref nst col) :type index-type)

166

(ub (aref nst (1+ col)) :type index-type))

167

(declare (type index-type row col))

168

                (if (or (= lb ub) (< row (aref nid lb)) (> row (aref nid (1- ub)))) (values -1 row col)

169

(values

170

(loop :with j := (ash (+ lb ub) -1)

171

:repeat 64

172

:do (cond

173

((= (aref nid j) row) (return j))

174

((>= lb (1- ub)) (return -1))

175

(t

176

(if (< row (aref nid j))

177

(setf ub j)

178

(setf lb (1+ j)))

179

(setf j (ash (+ lb ub) -1)))))

180

row col)))))

181

182

;; FIX 2025-05-22:

183

;; (deft t.store-allocator (cl compressed-sparse-matrix) (size &optional nz)

184

;; (let ((sto-type (store-element-type cl)))

185

;; `(destructuring-bind (nr nc) ,size

186

;; (let ((nz (or ,nz (min (ceiling (* nr nc *default-sparsity*)) *max-sparse-size*))))

187

;; (list

188

;; (allocate-index-store nz)

189

 ;;           (make-array (t/compute-store-size ,cl nz) :element-type ',sto-type :initial-element ,(if (subtypep sto-type 'number) `(t/fid+ ,sto-type) nil)))))))

190

191

;; (deft t.compute-store-size (sym compressed-sparse-matrix) (size)

192

;; size)

193

;; ;;

194

;; (deft t.store-type (sym compressed-sparse-matrix) (&optional (size '*))

195

;; `(simple-array ,(store-element-type sym) (,size)))

196

197

;; (deft t.store-ref (sym compressed-sparse-matrix) (store &rest idx)

198

;; (assert (null (cdr idx)) nil "given more than one index for compressed-store")

199

;; `(aref (the ,(store-type sym) ,store) (the index-type ,(car idx))))

200

201

;; (deft t.store-set (sym compressed-sparse-matrix) (value store &rest idx)

202

;; (assert (null (cdr idx)) nil "given more than one index for compressed store")

203

 ;;   `(setf (aref (the ,(store-type sym) ,store) (the index-type ,(car idx))) (the ,(field-type sym) ,value)))

204

205

;; (deft t.store-size (sym compressed-sparse-matrix) (ele)

206

;; `(length ,ele))

207

208

;; (deft t.store-element-type (sym compressed-sparse-matrix) ()

209

;; (macroexpand `(t/field-type ,sym)))

210

;;

211

(defmethod ref ((tensor compressed-sparse-matrix) &rest subscripts)

212

(let ((clname (class-name (class-of tensor))))

213

;; (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)

214

(compile-and-eval

215

`(defmethod ref ((tensor ,clname) &rest subscripts)

216

         (let ((idx (compressed-sparse-indexing (if (numberp (car subscripts)) subscripts (car subscripts)) tensor)))

217

(if (< idx 0)

218

(values (t.sparse-fill ,clname) nil)

219

(values (t.store-ref ,clname (store tensor) idx) t)))))

220

(apply #'ref (cons tensor subscripts))))

221

222

(defmethod (setf ref) (value (tensor compressed-sparse-matrix) &rest subscripts)

223

(let ((clname (class-name (class-of tensor))))

224

;; (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname)

225

(compile-and-eval

226

`(defmethod (setf ref) (value (tensor ,clname) &rest subscripts)

227

         (multiple-value-bind (idx row col) (compressed-sparse-indexing (if (numberp (car subscripts)) subscripts (car subscripts)) tensor)

228

(declare (type index-type idx row col))

229

(lety ((value (t/coerce ,(field-type clname) value) :type ,(field-type clname)))

230

(if (/= value (t/fid+ ,(field-type clname)))

231

(if (< idx 0)

232

(let* ((ns (neighbour-start tensor))

233

(value (t/coerce ,(field-type clname) value))

234

(row-data (let ((ni (neighbour-id tensor))

235

(vi (store tensor)))

236

(merge 'list

237

                                                   (list (cons row value))

238

                                                   (loop :for j :from (aref ns col) :below (aref ns (1+ col))

239

                                                         :collect (cons (aref ni j) (aref vi j)))

240

                                                   #'< :key #'car))))

241

(unless (> (store-size tensor) (aref ns (1- (length ns))))

242

                             (destructuring-bind (ni vi) (t.store-allocator ,clname (dims tensor) (+ (store-size tensor) *default-sparse-store-increment*))

243

(let ((nio (neighbour-id tensor))

244

(vio (store tensor)))

245

(very-quickly

246

(declare (type index-store-vector nio ni ns)

247

                                            (type ,(store-type clname) vio vi))

248

(loop :for i :from 0 :below (aref ns col)

249

                                         :do (setf (aref nio i) (aref ni i)

250

                                                   (aref vio i) (aref vi i)))

251

                                   (loop :for i :from (aref ns (1+ col)) :below (aref ns (1- (length ns)))

252

                                         :do (setf (aref nio (1+ i)) (aref ni i)

253

                                                   (aref vio (1+ i)) (aref vi i))))

254

(setf (slot-value tensor 'neighbour-id) ni

255

(slot-value tensor 'store) vi))))

256

(let ((ni (neighbour-id tensor))

257

(vi (store tensor)))

258

(very-quickly

259

(declare (type index-store-vector ni ns)

260

(type ,(store-type clname) vi))

261

(loop :for i :from (1+ col) :below (length ns)

262

:do (incf (aref ns i))))

263

(loop :for (r . v) :in row-data

264

:for i := (aref ns col) :then (1+ i)

265

:do (setf (aref ni i) r

266

(aref vi i) v))))

267

(t.store-set ,clname value (store tensor) idx))

268

(when (>= idx 0)

269

(let ((ns (neighbour-start tensor))

270

(ni (neighbour-id tensor))

271

(vi (store tensor)))

272

(very-quickly

273

(declare (type index-store-vector ns ni)

274

(type ,(store-type clname) vi))

275

(loop :for i :from idx :below (aref ns (1- (length ns)))

276

:do (setf (aref ni i) (aref ni (1+ i))

277

                                           (aref vi i) (aref vi (1+ i))))

278

(loop :for i :from (1+ col) :below (length ns)

279

:do (decf (aref ns i)))))))

280

value))))

281

(setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value)))