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

Kind	Covered	All	%
expression	0	1083	0.0
branch	0	82	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; base.lisp --- Tensor Base

2

3

;;

4

5

;;; Code:

6

(in-package :obj/tensor)

7

8

;;; Utils

9

(make-array-allocator allocate-index-store 'index-type 0

10

"Allocate index storage")

11

12

(definline make-index-store (contents)

13

"Allocate index storage with initial elements from the list CONTENTS."

14

(the index-store-vector (make-array (length contents) :element-type 'index-type

15

                                                         :initial-contents contents)))

16

17

(declaim (inline simple-array-type))

18

(defun simple-array-type (sym &optional (size '*))

19

"Create the list representing simple-array with type SYM."

20

`(simple-array ,sym (,size)))

21

22

;;; Base Tensor

23

(defclass base-tensor ()

24

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

25

                :documentation "Dimensions of the vector spaces in which the tensor's arguments reside.")

26

    ;; (parent-tensor :reader parent-tensor :initform nil :initarg :parent-tensor :type (or null base-tensor)

27

    ;;                :documentation "If the tensor is a view of another tensor, then this slot is bound.")

28

(store :initarg :store :reader store

29

:documentation "The actual storage for the tensor.")

30

;; (attributes :initarg :attributes :initform nil

31

;; :documentation "Place for computable attributes of an object instance.")

32

)

33

(:documentation "Basic tensor class."))

34

35

(defclass sparse-tensor (base-tensor) ())

36

(defclass dense-tensor (base-tensor) ())

37

38

(defmethod make-load-form ((tensor base-tensor) &optional env)

39

(make-load-form-saving-slots tensor :environment env))

40

41

(defmethod print-element ((tensor base-tensor) element stream)

42

(format stream "~a" element))

43

44

(definline rank (tensor)

45

(declare (type base-tensor tensor))

46

(length (the index-store-vector (slot-value tensor 'dimensions))))

47

48

(declaim (ftype (function (base-tensor &optional index-type) (or index-type index-store-vector)) dimensions))

49

(definline dimensions (x &optional idx)

50

(declare (type base-tensor x))

51

(if idx

52

       (the index-type (aref (the index-store-vector (slot-value x 'dimensions)) (modproj (or idx 0) (rank x) nil 0)))

53

(the index-store-vector (slot-value x 'dimensions))))

54

55

(defmethod size ((tensor base-tensor))

56

   (vector-foldr #'(lambda (x y) (declare (type index-type x y)) (the index-type (* x y))) (the index-store-vector (dimensions tensor))))

57

58

(definline dims (tensor &optional idx)

59

(declare (type base-tensor tensor))

60

(if idx (aref (dimensions tensor) (modproj (or idx 0) (rank tensor) nil 0))

61

(vector-to-list (the index-store-vector (dimensions tensor)))))

62

63

(labels ((array-subs (obj subscripts)

64

(let ((subs (etypecase (car subscripts)

65

(number subscripts)

66

(cons (car subscripts))

67

(vector (vector-to-list (car subscripts))))))

68

(loop for s on subs

69

for i = 0 then (1+ i)

70

do (when (< (car s) 0)

71

(rplaca s (modproj (car s) (array-dimension obj i) nil))))

72

subs)))

73

(defmethod ref ((obj array) &rest subscripts)

74

(apply #'aref obj (array-subs obj subscripts)))

75

(defmethod (setf ref) (value (obj array) &rest subscripts)

76

(apply #'(setf aref) value obj (array-subs obj subscripts))))

77

78

(labels ((list-subs (obj subscripts)

79

(let ((subs (etypecase (car subscripts)

80

(number subscripts)

81

(cons (car subscripts))

82

(vector (vector-to-list (car subscripts))))))

83

(assert (= (length subs) 1) nil 'invalid-argument) (setf subs (car subs))

84

(when (< subs 0) (setf subs (modproj subs (length obj))))

85

subs)))

86

(defmethod ref ((obj cons) &rest subscripts)

87

(elt obj (list-subs obj subscripts)))

88

(defmethod (setf ref) (value (obj cons) &rest subscripts)

89

(setf (elt obj (list-subs obj subscripts)) value)))

90

91

(defmethod store-ref ((tensor base-tensor) idx)

92

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

93

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

94

95

(defmethod (setf store-ref) (value (tensor base-tensor) idx)

96

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

97

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

98

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

99

100

(defmethod store-size ((tensor base-tensor))

101

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

102

(t.store-size clname (store tensor))))

103

104

(defmethod subtensor :before ((tensor base-tensor) (subscripts list))

105

(assert (or (null subscripts) (= (length subscripts) (rank tensor))) nil 'tensor-index-rank-mismatch))

106

107

(defun (setf subtensor) (value tensor subscripts)

108

(copy value (subtensor tensor subscripts)))

109

110

(definline parse-slice (subs dimensions)

111

(declare (type index-store-vector dimensions))

112

(let ((dims) (psubs))

113

(loop for sub.i in subs

114

for d of-type index-type across dimensions

115

do (if (not (consp sub.i))

116

(let ((idx (modproj (the (or index-type null) sub.i) d nil 0)))

117

(push 1 dims)

118

(push idx psubs))

119

(destructuring-bind (start end . inc) sub.i

120

(declare ((or index-type null) start end inc))

121

(let* ((inc (modproj inc nil nil 1))

122

(start (modproj start d nil (if (> inc 0) 0 (1- d))))

123

(end (modproj end d t (if (> inc 0) d -1)))

124

(nd (ceiling (- end start) inc)))

125

(declare (type index-type start end inc nd))

126

(when (<= nd 0) (return nil))

127

(push nd dims)

128

(push (list* start end inc) psubs))))

129

finally (return (values (nreverse psubs) (nreverse dims))))))

130

131

(definline parse-slice-for-strides (subscripts dimensions strides)

132

(declare (type index-store-vector dimensions strides)

133

(type list subscripts))

134

(let ((dims) (stds))

135

(loop for sub.i in subscripts

136

for d across dimensions

137

for s across strides

138

with hd = 0

139

if (not (consp sub.i))

140

do (let ((idx (modproj (the (or index-type null) sub.i) d nil 0)))

141

(incf hd (* s idx)))

142

else do

143

(destructuring-bind (start end . inc) sub.i

144

(declare ((or index-type null) start end inc))

145

(let* ((inc (modproj inc nil nil 1))

146

(start (modproj start d nil (if (> inc 0) 0 (1- d))))

147

(end (modproj end d t (if (> inc 0) d -1)))

148

(nd (ceiling (- end start) inc)))

149

(declare (type index-type start end inc nd))

150

(when (<= nd 0) (return nil))

151

(incf hd (* s start))

152

(push nd dims)

153

(push (* inc s) stds)))

154

finally (return (values hd (nreverse dims) (nreverse stds))))))

155

156

(definline slice (x axis &optional (idx 0) (preserve-rank-p (when (= (rank x) 1) t)))

157

(let* ((axis (modproj axis (rank x) nil 0))

158

(subs (loop for i from 0 below (rank x)

159

collect (cond ((/= i axis) '(nil nil))

160

(preserve-rank-p (list idx (1+ idx)))

161

(t idx)))))

162

(subtensor x subs)))

163

164

(definline row-slice (x idx)

165

(slice x 0 idx))

166

167

(definline col-slice (x idx)

168

(slice x 1 idx))

169

170

(defmethod suptensor :before ((tensor base-tensor) ord &optional (start 0))

171

(declare (type index-type start))

172

(let ((tord (rank tensor)))

173

     (assert (and (< -1 start) (<= tord (rank tensor)) (<= 0 start (- ord tord))) nil 'invalid-arguments)))

174

175

(definline matrixify (vec &optional (col-vectorp t))

176

(if (tensor-matrixp vec) vec (suptensor vec 2 (if col-vectorp 0 1))))

177

178

(defun tensor-typep (tensor subs)

179

"Check if the given tensor is of a particular size in particular arguments.

180

181

Checking for a vector:

182

(tensor-typep ten '(class-name *))

183

184

Checking for a matrix with 2 columns:

185

(tensor-typep ten '(real-tensor (* 2)))"

186

(declare (type base-tensor tensor))

187

(destructuring-bind (cls &optional subscripts) (ensure-list subs)

188

(and (typep tensor cls)

189

(if subscripts

190

(lety ((rank (rank tensor) :type index-type)

191

(dims (dimensions tensor) :type index-store-vector))

192

(loop :for val :in subscripts

193

:for i :of-type index-type := 0 :then (1+ i)

194

:do (unless (or (eq val '*) (eq val (aref dims i)))

195

(return nil))

196

:finally (return (when (= (1+ i) rank) t))))

197

t))))

198

199

(definline tensor-matrixp (ten)

200

(declare (type base-tensor ten))

201

(= (rank ten) 2))

202

203

(definline tensor-vectorp (ten)

204

(declare (type base-tensor ten))

205

(= (rank ten) 1))

206

207

(deftype base-square-matrix ()

208

`(and base-tensor (satisfies tensor-square-matrixp)))

209

210

(deftype base-matrix ()

211

`(and base-tensor (satisfies tensor-matrixp)))

212

213

(deftype base-vector ()

214

`(and base-tensor (satisfies tensor-vectorp)))

215

216

(definline tensor-squarep (tensor)

217

(declare (type base-tensor tensor))

218

(lety ((dims (dimensions tensor) :type index-store-vector))

219

(loop :for i :from 1 :below (length dims)

220

:do (unless (= (aref dims i) (aref dims 0))

221

(return nil))

222

:finally (return t))))

223

;;

224

(defun tensor-append (axis tensor &rest more-tensors)

225

(if (null tensor)

226

(when more-tensors

227

(apply #'tensor-append axis (car more-tensors) (cdr more-tensors)))

228

(let ((dims (copy-seq (dimensions tensor))))

229

(loop for ele in more-tensors do (incf (aref dims axis) (aref (dimensions ele) axis)))

230

(let* ((ret (%zeros dims (class-of tensor)))

231

(view (slice ret axis 0 t)))

232

(loop for ele in (cons tensor more-tensors)

233

with head = 0

234

do

235

(progn

236

(setf (slot-value view 'head) head

237

                            (aref (dimensions view) axis) (aref (dimensions ele) axis))

238

(copy ele view)

239

                      (incf head (* (aref (strides ret) axis) (aref (dimensions ele) axis)))))

240

ret))))

241

242

;;; Internal Tensor Protocols

243

(macrolet ((defn (sym num args &body body)

244

`(definline ,(symbolicate 't. (string sym)) ,(cons (car num) args)

245

(declare ,(reverse num) (optimize (speed 3) (space 0)))

246

,@body))

247

(def-marith (tname clop)

248

`(defn ,tname (num number) (&rest nums)

249

`(,',clop ,@(mapcar #'(lambda (x) `(the ,num ,x)) nums))))

250

(genarith (&rest args)

251

`(progn ,@(mapcar #'(lambda (x) `(def-marith ,(car x) ,(cadr x))) args))))

252

(genarith (f+ +) (f- -) (f* *) (f= =) (f/ /)))

253

254

(definline t.fid+ (ty)

255

(coerce 0 ty))

256

(definline t.fid* (ty)

257

(coerce 1 ty))

258

(definline t.fc (ty)

259

(etypecase ty

260

(real ty)

261

(t (conjugate ty))))

262

(defmethod fc ((x t))

263

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

264

(t.fc clname)))

265

(defun field-realp (fil)

266

(eql (t.fc fil) 'phi))

267

(definline t.frealpart (ty)

268

(etypecase ty

269

(real ty)

270

(t (realpart ty))))

271

(definline t.fimagpart (ty)

272

(etypecase ty

273

(real (t.fid+ 'real))

274

(t (imagpart ty))))

275

(definline t.coerce (val ty)

276

(if (and (consp ty) (eql (first ty) 'mod))

277

(mod (coerce val 'fixnum) (second ty))

278

(coerce val ty)))

279

280

;; HACK 2025-05-22: strict-coerce

281

;; (defun strict-compare (func-list a b)

282

;; (loop :for func :in func-list

283

;; :for elea :in a

284

;; :for eleb :in b

285

;; :do (unless (funcall func elea eleb)

286

;; (return nil))

287

;; :finally (return t)))

288

289

;; (defun dict-compare (func-list a b)

290

;; (loop :for func :in func-list

291

;; :for elea :in a

292

;; :for eleb :in b

293

;; :do (when (funcall func elea eleb)

294

;; (return t))))

295

296

;;;; Tensor Specialization

297

(definline t.field-type (sym)

298

(typecase sym

299

(base-tensor t)))

300

(defun field-type (clname)

301

(t.field-type clname))

302

303

(definline t.store-allocator (sym size &optional (initial-element 0))

304

(typecase sym

305

(standard-tensor

306

(let ((type (t.store-element-type sym)))

307

(lety* ((size-sym (t.compute-store-size sym (let ((sitm size))

308

                                                           (etypecase sitm

309

                                                             (index-type sitm)

310

                                                             (index-store-vector (vector-foldr

311

#'*

312

                                                                                  (the index-store-vector sitm)))

313

                                                             (cons (reduce #'* sitm))))))

314

(init initial-element)

315

                (arr (make-array size-sym :element-type type :initial-element (if (subtypep type 'number) (t.fid+ type) nil))))

316

(when initial-element

317

(loop :for idx :from 0 :below size-sym

318

:do (t.store-set sym init arr idx)))

319

arr)))))

320

321

(definline t.store-type (sym &optional (size '*))

322

(typecase sym

323

(standard-tensor

324

(simple-array-type (store-element-type sym) size))))

325

326

(defun store-type (cl &optional (size '*))

327

(t.store-type cl size))

328

329

(definline t.store-ref (sym store &rest idx)

330

(typecase sym

331

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

332

(aref store (the index-type (car idx))))))

333

334

(definline t.store-set (sym value store &rest idx)

335

(typecase sym

336

(linear-store

337

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

338

(setf (aref store (the index-type (car idx))) value))))

339

340

(define-setf-expander t.store-ref (sym store &rest idx &environment env)

341

(multiple-value-bind (dummies vals newval setter getter)

342

(get-setf-expansion store env)

343

(declare (ignore newval setter))

344

(with-gensyms (nval)

345

(values dummies

346

vals

347

`(,nval)

348

`(t.store-set ,sym ,nval ,getter ,@idx)

349

`(t.store-ref ,sym ,getter ,@idx)))))

350

351

(definline t.store-element-type (sym)

352

(t.field-type sym))

353

354

(defun store-element-type (clname)

355

(t.store-element-type clname))

356

357

(definline t.compute-store-size (sym size)

358

(typecase sym

359

(standard-tensor size)))

360

361

(definline t.store-size (sym ele)

362

(typecase sym

363

(standard-tensor (length ele))))

364

365

(defun with-field-element (sym decl &rest body)

366

(destructuring-bind (var init &optional (count 1)) decl

367

`(lety ((,var (t.store-allocator ,sym ,count ,init) :type ,(store-type sym)))

368

,@body)))

369

370

(defmacro with-field-elements (sym decls &rest body)

371

(if (null decls) `(progn ,@body)

372

`(with-field-element ,sym ,(first decls)

373

(with-field-elements ,sym ,(cdr decls) ,@body))))

374

375

(defparameter *tensor-methods* (make-hash-table))

376

377

(definline lazy-coerce (x out)

378

(if (typep x out) x

379

(copy x out)))

380

381

(defun cclass-max (lst)

382

(let ((max nil))

383

(loop :for ele :in lst

384

;; FIX 2025-05-22:

385

:do (when (or (null max) #+nil (and (coerceable-p max ele)

386

                                               (or (not (coerceable-p ele max))

387

                                                   (and (subtypep ele 'blas-numeric-tensor) (subtypep max 'blas-numeric-tensor)

388

                                                        (> (float-digits (coerce 0 (store-element-type ele)))

389

                                                           (float-digits (coerce 0 (store-element-type max))))))))

390

(setf max ele)))

391

max))

392

393

(defmacro define-tensor-method (name (&rest args) &body body)

394

   (let* ((inputs (mapcar #'car (remove-if-not #'(lambda (x) (and (consp x) (eql (third x) :input))) args)))

395

          (outputs (mapcar #'car (remove-if-not #'(lambda (x) (and (consp x) (eql (third x) :output))) args)))

396

(iclsym (zipsym inputs))

397

(oclsym (zipsym outputs))

398

(dargs (let ((pos (position-if #'(lambda (x) (member x cl:lambda-list-keywords)) args)))

399

(if pos (subseq args 0 pos) args))))

400

(with-gensyms (x classes iclasses oclasses)

401

`(progn

402

(multiple-value-bind (val exists?) (gethash ',name *tensor-methods*)

403

(if exists?

404

                (let ((type-meths (assoc ',(mapcar #'(lambda (x) (if (consp x) (cadr x) t)) dargs) (cdr val) :test #'tree-equal)))

405

(if type-meths

406

(progn

407

(loop :for ele in (cdr type-meths)

408

:do (remove-method (symbol-function ',name) ele))

409

(setf (cdr type-meths) nil))

410

                      (setf (cdr val) (list* (list ',(mapcar #'(lambda (x) (if (consp x) (cadr x) t)) dargs)) (cdr val)))))

411

                (setf (gethash ',name *tensor-methods*) (list ',name (list ',(mapcar #'(lambda (x) (if (consp x) (cadr x) t)) dargs))))))

412

;;

413

(defmethod ,name (,@(mapcar #'(lambda (x) (if (consp x) (subseq x 0 2) x)) args))

414

            (let* (,@(mapcar #'(lambda (lst) `(,(car lst) (class-name (class-of ,(cadr lst))))) (append iclsym oclsym))

415

(,iclasses (list ,@(mapcar #'car iclsym)))

416

(,oclasses (list ,@(mapcar #'car oclsym)))

417

(,classes (append ,iclasses ,oclasses)))

418

(labels ((generate-code (class)

419

                         (let ((args (mapcar #'(lambda (x) (if (and (consp x) (member (third x) '(:input :output)))

420

                                                               (list (car x) class)

421

x))

422

'(,@args)))

423

(ebody (macrolet ((cl (,x)

424

                                                   (let ((slook '(,@(mapcar #'(lambda (x) `(,(cadr x) class)) iclsym)

425

                                                                  ,@(mapcar #'(lambda (x) `(,(cadr x) class)) oclsym))))

426

                                                     (or (cadr (assoc ,x slook)) (error "Can't find class of ~a" ,x)))))

427

(list ,@body))))

428

`(defmethod ,',name (,@args)

429

,@ebody))))

430

(cond

431

((every #'(lambda (,x) (eql ,x (car ,classes))) ,classes)

432

;; (assert (member (car ,classes) *tensor-type-leaves*)

433

;; nil 'tensor-abstract-class :tensor-class ,classes)

434

(let* ((method (compile-and-eval (generate-code (car ,classes))))

435

                          (lst (assoc ',(mapcar #'(lambda (x) (if (consp x) (cadr x) t)) dargs) (cdr (gethash ',name *tensor-methods*)) :test #'tree-equal)))

436

(assert lst nil "Method table missing from *tensor-methods*")

437

(setf (cdr lst) (list* method (cdr lst))))

438

                   (,name ,@(mapcar  #'(lambda (x) (if (consp x) (car x) x)) (remove-if #'(lambda (x) (member x cl:lambda-list-keywords)) args))))

439

((and (every #'(lambda (,x) (eql ,x (car ,oclasses))) ,oclasses)

440

                        (or (null ,oclasses) (coerceable-p (cclass-max ,iclasses) (car ,oclasses))))

441

(let* ((clm (or (car ,oclasses) (cclass-max ,iclasses)))

442

,@(mapcar #'(lambda (x) `(,x (lazy-coerce ,x clm))) inputs))

443

(declare (ignorable clm))

444

                     (,name ,@(mapcar  #'(lambda (x) (if (consp x) (car x) x)) (remove-if #'(lambda (x) (member x cl:lambda-list-keywords)) args)))))

445

(t

446

                   (error "Don't know how to apply ~a to classes ~a, ~a." ',name ,iclasses ,oclasses))))))))))

447

448

;;;; Standard Tensor

449

(defclass linear-store ()

450

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

451

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

452

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

453

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

454

(store :initarg :store :reader store :type vector

455

:documentation "The actual storage for the tensor.")))

456

457

(declaim (ftype (function (base-tensor &optional index-type) (or index-type index-store-vector)) strides)

458

(ftype (function (base-tensor) index-type) head))

459

460

(definline strides (x &optional idx)

461

(declare (type base-tensor x))

462

(if idx

463

(aref (the index-store-vector (slot-value x 'strides)) (modproj (or idx 0) (rank x) nil 0))

464

(the index-store-vector (slot-value x 'strides))))

465

466

(defun store-indexing-vec (idx hd strides dims)

467

"Does error checking to make sure IDX is not out of bounds.

468

469

Returns the sum:

470

471

length(STRIDES)

472

__

473

HD + \ STRIDE * IDX

474

/_ i i

475

i = 0"

476

(declare (type index-type hd)

477

(type index-store-vector idx strides dims))

478

(lety ((rank (length strides) :type index-type))

479

         (assert (= rank (length idx) (length dims)) nil 'tensor-index-rank-mismatch :index-rank (length idx) :rank rank)

480

(loop

481

:for i :of-type index-type :from 0 :below rank

482

:for cidx :across idx

483

:for d :across dims

484

:for s :across strides

485

:with sto-idx :of-type index-type := hd

486

:do (progn

487

                 (assert (< (1- (- d)) cidx d) nil 'tensor-index-out-of-bounds :argument i :index cidx :dimension d)

488

(incf sto-idx (the index-type (* s (if (< cidx 0) (mod cidx d) cidx)))))

489

:finally (return sto-idx))))

490

491

(defun store-indexing-lst (idx hd strides dims)

492

"Does error checking to make sure idx is not out of bounds.

493

494

Returns the sum:

495

496

length(STRIDES)

497

__

498

HD + \ STRIDE * IDX

499

/_ i i

500

i = 0"

501

(declare (type index-type hd)

502

(type index-store-vector strides dims)

503

(type cons idx))

504

(lety ((rank (length strides) :type index-type))

505

(loop :for cidx :of-type index-type :in idx

506

:for i :of-type index-type := 0 :then (1+ i)

507

:for d :across dims

508

:for s :across strides

509

:with sto-idx :of-type index-type := hd

510

:do (progn

511

                     (assert (< (1- (- d)) cidx d) nil 'tensor-index-out-of-bounds :argument i :index cidx :dimension d)

512

                     (incf sto-idx (the index-type (* s (if (< cidx 0) (mod cidx d) cidx)))))

513

:finally (progn

514

                          (assert (= (1+ i) rank) nil 'tensor-index-rank-mismatch :index-rank (1+ i) :rank rank)

515

(return sto-idx)))))

516

517

(definline store-indexing (idx tensor)

518

"Returns the linear index of the element pointed by IDX. Does error checking to

519

make sure idx is not out of bounds.

520

521

Returns the sum:

522

523

length(STRIDES)

524

__

525

HD + \ STRIDES * IDX

526

/_ i i

527

i = 0"

528

(etypecase idx

529

(cons (store-indexing-lst idx (head tensor) (strides tensor) (dimensions tensor)))

530

(vector (store-indexing-vec idx (head tensor) (strides tensor) (dimensions tensor)))))

531

532

;;Stride makers.

533

(macrolet ((defstride (fname col?)

534

`(definline ,fname (dims)

535

(declare (type index-store-vector dims))

536

(lety ((stds (allocate-index-store (length dims)) :type index-store-vector))

537

(loop

538

,@(if col?

539

`(for i from 0 below (length dims))

540

`(for i from (1- (length dims)) downto 0))

541

with st = 1

542

do (locally (declare (fixnum i st))

543

(lety ((d (aref dims i) :type index-type))

544

                                    (assert (> d 0) nil 'tensor-invalid-dimension-value :argument i :dimension d)

545

(setf (aref stds i) st

546

st (* st d))))

547

finally (return (values stds st)))))))

548

(defstride make-stride-cmj t)

549

(defstride make-stride-rmj nil)

550

(definline make-stride (dims)

551

     (ecase *default-stride-ordering* (:row-major (make-stride-rmj dims)) (:col-major (make-stride-cmj dims)))))

552

553

;;; Standard Tensor

554

;;Is it a tensor, a linear-store ? It is both!

555

(defclass standard-tensor (dense-tensor linear-store) ())

556

557

(defmethod initialize-instance :after ((tensor standard-tensor) &rest initargs)

558

(declare (ignore initargs))

559

(when *tensor-safety-p*

560

(lety ((dims (dimensions tensor) :type index-store-vector))

561

           (assert (>= (head tensor) 0) nil 'tensor-invalid-head-value :head (head tensor) :tensor tensor)

562

(if (not (slot-boundp tensor 'strides))

563

(multiple-value-bind (stds size) (make-stride dims)

564

(declare (index-store-vector stds)

565

(index-type size))

566

(setf (slot-value tensor 'strides) stds)

567

                 (assert (<= (+ (head tensor) size) (store-size tensor)) nil 'tensor-insufficient-store :store-size (store-size tensor) :max-idx (+ (head tensor) (1- (size tensor))) :tensor tensor))

568

(lety ((stds (strides tensor) :type index-store-vector))

569

(loop :for i :of-type index-type :from 0 :below (rank tensor)

570

:for sz :of-type index-type := (aref dims 0)

571

:then (the index-type (* sz (aref dims i)))

572

                           :summing (the index-type (* (aref stds i) (1- (aref dims i)))) :into lidx :of-type index-type

573

                           :do (assert (> (aref dims i) 0) nil 'tensor-invalid-dimension-value :argument i :dimension (aref dims i) :tensor tensor)

574

                           :finally (assert (>= (the index-type (store-size tensor)) (the index-type (+ (the index-type (head tensor)) lidx)) 0) nil 'tensor-insufficient-store :store-size (store-size tensor) :max-idx (the index-type (+ (head tensor) lidx)) :tensor tensor)))))))

575

576

(defmethod ref ((tensor standard-tensor) &rest subscripts)

577

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

578

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

579

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

580

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

581

582

(defmethod (setf ref) (value (tensor standard-tensor) &rest subscripts)

583

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

584

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

585

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

586

(idx (store-indexing subs tensor))

587

(sto (store tensor)))

588

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

589

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

590

591

;; (defmethod subtensor ((tensor standard-tensor) (subscripts list))

592

 ;;   (multiple-value-bind (hd dims stds) (parse-slice-for-strides subscripts (dimensions tensor) (strides tensor))

593

;; (cond

594

;; ((not hd) nil)

595

;; ((not dims) (if subscripts

596

;; (store-ref tensor hd)

597

;; (with-no-init-checks

598

;; (make-instance (class-of tensor)

599

;; :head (head tensor)

600

 ;;                                          :dimensions (copy-seq (dimensions tensor))

601

 ;;                                          :strides (copy-seq (strides tensor))

602

;; :store (store tensor)

603

;; :parent-tensor tensor))))

604

;; (t (with-no-init-checks

605

;; (make-instance (class-of tensor)

606

;; :head (+ hd (head tensor))

607

;; :dimensions (make-index-store dims)

608

;; :strides (make-index-store stds)

609

;; :store (store tensor)

610

;; :parent-tensor tensor))))))

611

612

;; (defmethod suptensor ((ten standard-tensor) ord &optional (start 0))

613

;; (declare (type index-type ord start))

614

;; (if (= (rank ten) ord) ten

615

;; (let* ((tord (rank ten)))

616

;; (with-no-init-checks

617

;; (make-instance (class-of ten)

618

;; :dimensions (make-index-store

619

 ;;                                         (nconc (make-list start :initial-element 1)

620

 ;;                                                (vector-to-list (dimensions ten))

621

 ;;                                                (make-list (- ord tord start) :initial-element 1)))

622

;; :strides (make-index-store

623

 ;;                                      (nconc (make-list start :initial-element (size ten))

624

 ;;                                             (vector-to-list (strides ten))

625

 ;;                                             (make-list (- ord tord start) :initial-element (size ten))))

626

;; :head (head ten)

627

;; :store (store ten)

628

;; :parent-tensor ten)))))

629

630

;; (defmethod reshape :before ((tensor standard-tensor) (dims cons))

631

;; (assert (loop for s across (strides tensor)

632

;; unless (> (* s (strides tensor 0)) 0) return nil

633

;; finally (return t))

634

;; nil 'tensor-error :message "strides are not of the same sign." :tensor tensor)

635

;; ;; FIX 2025-05-22:

636

 ;;   (assert (<= (loop for i in dims collect (multiplying i)) (store-size tensor)) nil 'tensor-insufficient-store))

637

638

(defmethod reshape ((ten standard-tensor) (dims cons))

639

(let ((idim (make-index-store dims)))

640

(setf (slot-value ten 'dimensions) idim

641

(slot-value ten 'strides) (let ((strd (make-stride idim)))

642

(when (< (strides ten 0) 0)

643

                                         (loop for i from 0 below (length strd)

644

                                               do (setf (aref strd i) (- (aref strd i)))))

645

strd))

646

ten))

647

648

;;; Einstein

649

;;; Permutation