serial.lisp (6920B)
1 (defpackage :serial 2 (:use :common-lisp :blas :tensor) 3 (:export :serialize 4 :deserialize)) 5 6 (in-package :serial) 7 8 (eval-when (:compile-toplevel :load-toplevel :execute) 9 (defparameter *types* 10 '(fixnum double-float list (array blas-float) array sector segment tensor))) 11 12 (defparameter *serializers* (make-array (length *types*) :element-type 'compiled-function)) 13 (defparameter *deserializers* (make-array (length *types*) :element-type 'compiled-function)) 14 15 (defconstant +index-size+ 1) 16 (defconstant +fixnum-size+ 4) 17 18 (defmacro defser (type (obj buf pos) &body body) 19 (let ((i (position type *types* :test #'subtypep))) 20 `(setf (svref *serializers* ,i) 21 (lambda (,obj ,buf ,pos) 22 (declare 23 (type (array (unsigned-byte 8)) buf) 24 (type fixnum pos)) 25 (if (plusp (length buf)) 26 (pack ,i +index-size+ ,buf ,pos)) 27 (incf pos +index-size+) 28 (+ +index-size+ (progn ,@body)))))) 29 30 (defmacro defdes (type (buf pos) &body body) 31 (let ((i (position type *types* :test #'subtypep))) 32 `(setf (svref *deserializers* ,i) 33 (lambda (,buf ,pos) 34 (declare 35 (type fixnum pos)) 36 ,@body)))) 37 38 (declaim (inline pack unpack)) 39 40 (defun pack (val size buf pos) 41 (declare 42 (type fixnum val size pos) 43 (type (simple-array (unsigned-byte 8)) buf)) 44 (case size 45 (1 (setf 46 (sb-sys:sap-ref-8 47 (sb-sys:vector-sap (sb-ext:array-storage-vector buf)) 48 pos) 49 val)) 50 (4 (setf 51 (sb-sys:signed-sap-ref-32 52 (sb-sys:vector-sap (sb-ext:array-storage-vector buf)) 53 pos) 54 val)))) 55 56 (defun unpack (size buf pos) 57 (declare 58 (type fixnum size pos) 59 (type (simple-array (unsigned-byte 8)) buf)) 60 (case size 61 (1 (sb-sys:sap-ref-8 62 (sb-sys:vector-sap (sb-ext:array-storage-vector buf)) 63 pos)) 64 (4 (sb-sys:signed-sap-ref-32 65 (sb-sys:vector-sap (sb-ext:array-storage-vector buf)) 66 pos)))) 67 68 (defun ser (obj buf pos) 69 (funcall 70 (svref 71 *serializers* 72 #.`(etypecase obj 73 ,@(loop 74 for i below (length *types*) 75 collect (list (nth i *types*) i)))) 76 obj 77 buf 78 pos)) 79 80 (defun des (buf pos) 81 (declare (type fixnum pos)) 82 (multiple-value-bind (val size) 83 (funcall 84 (svref *deserializers* (unpack +index-size+ buf pos)) 85 buf 86 (+ pos +index-size+)) 87 (declare (type fixnum size)) 88 (values val (+ +index-size+ size)))) 89 90 (defser fixnum (obj buf pos) 91 (if (plusp (length buf)) 92 (pack obj +fixnum-size+ buf pos)) 93 +fixnum-size+) 94 95 (defdes fixnum (buf pos) 96 (values (unpack +fixnum-size+ buf pos) +fixnum-size+)) 97 98 (defser double-float (obj buf pos) 99 (if (plusp (length buf)) 100 (setf 101 (sb-sys:sap-ref-double 102 (sb-sys:vector-sap (sb-ext:array-storage-vector buf)) 103 pos) 104 obj)) 105 8) 106 107 (defdes double-float (buf pos) 108 (values (sb-sys:sap-ref-double 109 (sb-sys:vector-sap (sb-ext:array-storage-vector buf)) 110 pos) 111 8)) 112 113 (defser list (obj buf pos) 114 (if (plusp (length buf)) 115 (pack (length obj) +fixnum-size+ buf pos)) 116 (let ((i +fixnum-size+)) 117 (declare (type fixnum i)) 118 (dolist (x obj i) 119 (incf i (the fixnum (ser x buf (+ pos i))))))) 120 121 (defdes list (buf pos) 122 (let ((n (unpack +fixnum-size+ buf pos)) 123 (i +fixnum-size+) 124 (obj nil)) 125 (declare (type fixnum n i)) 126 (dotimes (j n (values (nreverse obj) i)) 127 (multiple-value-bind (val size) (des buf (+ pos i)) 128 (declare (type fixnum size)) 129 (incf i size) 130 (push val obj))))) 131 132 (defser array (obj buf pos) 133 (let* ((d (array-dimensions obj)) 134 (i (ser d buf pos))) 135 (declare (type fixnum i)) 136 (dotimes (j (array-total-size obj) i) 137 (incf i (the fixnum (ser (row-major-aref obj j) buf (+ pos i))))))) 138 139 (defdes array (buf pos) 140 (multiple-value-bind (d i) (des buf pos) 141 (declare (type list d)) 142 (declare (type fixnum i)) 143 (let ((obj (make-array d))) 144 (dotimes (j (array-total-size obj) (values obj i)) 145 (multiple-value-bind (val size) (des buf (+ pos i)) 146 (declare (type fixnum size)) 147 (incf i size) 148 (setf (row-major-aref obj j) val)))))) 149 150 (defser (array blas-float) (obj buf pos) 151 (let* ((d (array-dimensions obj)) 152 (n (* (array-total-size obj) +blas-float-size+)) 153 (i (ser d buf pos))) 154 (declare (type fixnum n i)) 155 (if (plusp (length buf)) 156 (sb-sys:with-pinned-objects 157 ((sb-ext:array-storage-vector obj) 158 (sb-ext:array-storage-vector buf)) 159 (sb-sys:memmove 160 (sb-alien:sap-alien 161 (sb-sys:sap+ 162 (sb-sys:vector-sap (sb-ext:array-storage-vector buf)) 163 (+ pos i)) 164 (* char)) 165 (sb-alien:sap-alien 166 (sb-sys:vector-sap (sb-ext:array-storage-vector obj)) 167 (* char)) 168 n))) 169 (+ i n))) 170 171 (defdes (array blas-float) (buf pos) 172 (multiple-value-bind (d i) (des buf pos) 173 (declare (type list d)) 174 (declare (type fixnum i)) 175 (let* ((obj (make-blas-array d)) 176 (n (* (array-total-size obj) +blas-float-size+))) 177 (declare (type fixnum n)) 178 (sb-sys:with-pinned-objects 179 ((sb-ext:array-storage-vector obj) 180 (sb-ext:array-storage-vector buf)) 181 (sb-sys:memmove 182 (sb-alien:sap-alien 183 (sb-sys:vector-sap (sb-ext:array-storage-vector obj)) 184 (* char)) 185 (sb-alien:sap-alien 186 (sb-sys:sap+ 187 (sb-sys:vector-sap (sb-ext:array-storage-vector buf)) 188 (+ pos i)) 189 (* char)) 190 n)) 191 (values obj (+ i n))))) 192 193 (defser sector (obj buf pos) 194 (let ((i (ser (sector-numbers obj) buf pos))) 195 (declare (type fixnum i)) 196 (+ i (the fixnum (ser (sector-array obj) buf (+ pos i)))))) 197 198 (defdes sector (buf pos) 199 (declare (type fixnum pos)) 200 (multiple-value-bind (val1 size1) (des buf pos) 201 (declare (type fixnum size1)) 202 (multiple-value-bind (val2 size2) (des buf (+ pos size1)) 203 (declare (type fixnum size2)) 204 (values (make-sector :numbers val1 :array val2) (+ size1 size2))))) 205 206 (defser segment (obj buf pos) 207 (let ((i (ser (segment-numbers obj) buf pos))) 208 (declare (type fixnum i)) 209 (+ i (the fixnum (ser (segment-dimension obj) buf (+ pos i)))))) 210 211 (defdes segment (buf pos) 212 (declare (type fixnum pos)) 213 (multiple-value-bind (val1 size1) (des buf pos) 214 (declare (type fixnum size1)) 215 (multiple-value-bind (val2 size2) (des buf (+ pos size1)) 216 (declare (type fixnum size2)) 217 (values (make-segment :numbers val1 :dimension val2) (+ size1 size2))))) 218 219 (defser tensor (obj buf pos) 220 (let ((i (ser (tensor-indices obj) buf pos))) 221 (declare (type fixnum i)) 222 (+ i (the fixnum (ser (tensor-sectors obj) buf (+ pos i)))))) 223 224 (defdes tensor (buf pos) 225 (declare (type fixnum pos)) 226 (multiple-value-bind (val1 size1) (des buf pos) 227 (declare (type fixnum size1)) 228 (multiple-value-bind (val2 size2) (des buf (+ pos size1)) 229 (declare (type fixnum size2)) 230 (values (make-tensor :indices val1 :sectors val2) (+ size1 size2))))) 231 232 (defun size (obj) 233 (ser obj (make-array 0 :element-type '(unsigned-byte 8)) 0)) 234 235 (defun serialize (obj) 236 (let* ((buf (make-array (size obj) :element-type '(unsigned-byte 8)))) 237 (ser obj buf 0) 238 buf)) 239 240 (defun deserialize (buf) 241 (des buf 0))