Coverage report: /home/ellis/comp/core/lib/io/static.lisp

Kind	Covered	All	%
expression	151	439	34.4
branch	14	36	38.9

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; static.lisp --- Static Storage IO

2

3

;; Vectors allocated in static memory. Useful for things like IO buffers

4

;; created from Lisp and shared with C code.

5

6

;;; Commentary:

7

8

;; The source here is pulled directly from the STATIC-VECTORS package on

9

;; Quicklisp: https://github.com/sionescu/static-vectors

10

11

;;; Code:

12

(in-package :io/static)

13

;;; --- Checking for compile-time constants and evaluating such forms

14

15

(defun quotedp (form)

16

(and (listp form)

17

(= 2 (length form))

18

(eql 'quote (car form))))

19

20

(defun qconstantp (form &optional env)

21

(let ((form (if (symbolp form)

22

(macroexpand form env)

23

form)))

24

(or (quotedp form)

25

(cl:constantp form))))

26

27

(defun eval-constant (form &optional env)

28

(declare (ignorable env))

29

(if (quotedp form)

30

(second form)

31

(sb-int:constant-form-value form env)))

32

33

(defun canonicalize-args (env element-type length)

34

(let* ((eltype-spec (or (and (qconstantp element-type)

35

(ignore-errors

36

(upgraded-array-element-type

37

(eval-constant element-type))))

38

'*))

39

(length-spec (if (qconstantp length env)

40

`,(eval-constant length env)

41

'*))

42

(type-decl (if (eql '* eltype-spec)

43

'simple-array

44

`(simple-array ,eltype-spec (,length-spec)))))

45

(values (if (eql '* eltype-spec)

46

element-type

47

`(quote ,eltype-spec))

48

(if (eql '* length-spec)

49

length

50

length-spec)

51

type-decl)))

52

53

;;; --- SBCL implementation

54

(declaim (inline fill-foreign-memory))

55

(defun fill-foreign-memory (pointer length value)

56

"Fill LENGTH octets in foreign memory area POINTER with VALUE."

57

(std/alien:memset pointer value length)

58

pointer)

59

60

(declaim (inline replace-foreign-memory))

61

(defun replace-foreign-memory (dst-ptr src-ptr length)

62

"Copy LENGTH octets from foreign memory area SRC-PTR to DST-PTR."

63

(std/alien:memcpy dst-ptr src-ptr length)

64

dst-ptr)

65

66

;;; We have to handle all the low-level bits including setting the array header

67

;;; and keeping around the info about the original pointer returned by the

68

;;; foreign allocator.

69

;;;

70

;;; It goes like this:

71

;;;

72

;;; 1. Compute the data size for the Lisp-visible memory (that means an extra #\Nul

73

;;; at the end for strings)

74

;;; 2. Sum the data size, the SBCL header size, and our extra header size to get

75

;;; the total foreign size required

76

;;; 3. Adjust the total foreign size to the required alignment, compute the header offset

77

;;; and write the headers.

78

;;;

79

;;; Array layout:

80

;;;

81

;;; +-------------------+

82

;;; | Allocated address | <-- Original pointer

83

;;; +-------------------+

84

;;; | Start gap ... | <-- For large alignments, there's a gap between

85

;;; | | the data block and the headers.

86

;;; +-------------------+

87

;;; | SV header | <-- The offset from the original pointer (DWORD)

88

;;; +-------------------+

89

;;; | Lisp array header | <-- Array element-type and size (DWORD)

90

;;; +-------------------+

91

;;; | Lisp array data | <-- Lisp-visible data

92

;;; +-------------------+

93

;;;

94

;;; There's no end gap because when a alignment is requested,

95

;;; the requested size must also be a multiple of the alignment.

96

97

(defconstant +array-header-size+

98

(* sb-vm:vector-data-offset sb-vm:n-word-bytes))

99

100

(declaim (inline vector-widetag-and-n-bytes))

101

(defun vector-widetag-and-n-bytes (type)

102

"Returns the widetag and octet size of the upgraded array element type

103

for a given type specifier."

104

(let ((upgraded-type (upgraded-array-element-type type)))

105

(case upgraded-type

106

((nil t) (error "~A is not a specializable array element type" type))

107

(t

108

#+#.(cl:if (cl:find-symbol "%VECTOR-WIDETAG-AND-N-BITS" "SB-IMPL")

109

'(and) '(or))

110

(sb-impl::%vector-widetag-and-n-bits type)

111

#+#.(cl:if (cl:find-symbol "%VECTOR-WIDETAG-AND-N-BITS-SHIFT" "SB-IMPL")

112

'(and) '(or))

113

(multiple-value-bind (widetag shift)

114

(sb-impl::%vector-widetag-and-n-bits-shift type)

115

(values widetag (expt 2 (- shift 3))))))))

116

117

(declaim (inline align))

118

(defun align (size boundary)

119

(* boundary

120

(ceiling size boundary)))

121

122

(declaim (inline %memalign))

123

(defun %memalign (size alignment)

124

(with-alien ((box (* t)))

125

(let ((errno

126

(std/alien:posix-memalign (addr box) alignment size)))

127

(when (not (zerop errno))

128

(error "posix_memalign() returned error ~A" errno))

129

box)))

130

131

(defun %allocate-static-vector (length element-type alignment)

132

(declare (type (unsigned-byte 16) alignment))

133

(flet ((allocation-sizes (length widetag n-bytes)

134

(values

135

;; We're allocating two headers: one for SBCL and

136

;; the other one for our bookkeeping.

137

(align (* 2 +array-header-size+) alignment)

138

;; Align data size.

139

(align

140

(* (if (= widetag sb-vm:simple-character-string-widetag)

141

(1+ length) ; for the final #\Nul

142

length)

143

n-bytes)

144

alignment))))

145

(multiple-value-bind (widetag n-bytes)

146

(vector-widetag-and-n-bytes element-type)

147

(multiple-value-bind (header-size data-size)

148

(allocation-sizes length widetag n-bytes)

149

(let* ((total-size (+ header-size data-size))

150

(foreign-block (%memalign total-size alignment))

151

(data-offset header-size )

152

(lisp-header-offset

153

(- data-offset +array-header-size+))

154

(lisp-header-pointer

155

(sb-sys:sap+ (alien-sap foreign-block) lisp-header-offset))

156

(extra-header-offset

157

(- data-offset (* 2 +array-header-size+)))

158

(extra-header-pointer

159

(sb-sys:sap+ (alien-sap foreign-block) extra-header-offset)))

160

;; Write Lisp header: tag and length

161

(setf (sb-sys:sap-ref-word lisp-header-pointer 0) widetag)

162

(setf (sb-sys:sap-ref-word lisp-header-pointer sb-vm:n-word-bytes)

163

(sb-vm:fixnumize length))

164

;; Save the relative position from the start of the foreign block

165

(setf (sb-sys:sap-ref-word extra-header-pointer 0)

166

(- data-offset (* 2 +array-header-size+)))

167

;; Instantiate Lisp object

168

(sb-kernel:%make-lisp-obj (logior (sb-sys:sap-int lisp-header-pointer)

169

                                             sb-vm:other-pointer-lowtag)))))))

170

171

(declaim (inline static-vector-address))

172

(defun static-vector-address (vector)

173

"Return a foreign pointer to start of the Lisp VECTOR (including its header).

174

VECTOR must be a vector created by MAKE-STATIC-VECTOR."

175

(logandc2 (sb-kernel:get-lisp-obj-address vector)

176

sb-vm:lowtag-mask))

177

178

(declaim (inline static-vector-pointer))

179

(defun static-vector-pointer (vector &key (offset 0))

180

"Return a foreign pointer to the beginning of VECTOR + OFFSET octets.

181

VECTOR must be a vector created by MAKE-STATIC-VECTOR."

182

(check-type offset unsigned-byte)

183

(sb-sys:int-sap (+ (static-vector-address vector)

184

+array-header-size+

185

offset)))

186

187

(declaim (inline free-static-vector))

188

(defun free-static-vector (vector)

189

"Free VECTOR, which must be a vector created by MAKE-STATIC-VECTOR."

190

(declare (sb-ext:muffle-conditions sb-ext:compiler-note))

191

(let* ((extra-header-pointer

192

(sb-sys:int-sap (- (static-vector-address vector) +array-header-size+)))

193

(start-offset

194

(sb-sys:sap-ref-word extra-header-pointer 0)))

195

(free-alien (sap-alien (sb-sys:sap+ extra-header-pointer (- start-offset)) (* (unsigned 8)))))

196

(values))

197

198

;;; --- MAKE-STATIC-VECTOR

199

(declaim (inline check-initial-element))

200

(defun check-initial-element (element-type initial-element)

201

(when (not (typep initial-element element-type))

202

(error "MAKE-STATIC-VECTOR: The type of :INITIAL-ELEMENT ~S is not a subtype ~

203

of the array's :ELEMENT-TYPE ~S"

204

initial-element element-type)))

205

206

(declaim (inline check-initial-contents))

207

(defun check-initial-contents (length initial-contents)

208

(let ((initial-contents-length (length initial-contents)))

209

(when (/= length initial-contents-length)

210

;; FIXME: signal TYPE-ERROR

211

(error "MAKE-STATIC-VECTOR: There are ~A elements in the :INITIAL-CONTENTS, ~

212

but requested vector length is ~A."

213

initial-contents-length length))))

214

215

(declaim (inline check-initialization-arguments))

216

(defun check-initialization-arguments (initial-element-p initial-contents-p)

217

(when (and initial-element-p initial-contents-p)

218

;; FIXME: signal ARGUMENT-LIST-ERROR

219

(error "MAKE-STATIC-VECTOR: You must not specify both ~

220

:INITIAL-ELEMENT and :INITIAL-CONTENTS")))

221

222

(defun check-arguments (length element-type

223

initial-element initial-element-p

224

initial-contents initial-contents-p)

225

(check-initialization-arguments initial-element-p initial-contents-p)

226

(check-type length non-negative-fixnum)

227

(when initial-element-p

228

(check-initial-element element-type initial-element))

229

(when initial-contents-p

230

(check-initial-contents length initial-contents)))

231

232

(defconstant +default-alignment+ 16)

233

(defconstant +max-alignment+ 4096)

234

235

(declaim (inline make-static-vector))

236

(defun make-static-vector (length &key (element-type '(unsigned-byte 8))

237

                                        (initial-element nil initial-element-p)

238

                                        (initial-contents nil initial-contents-p)

239

(alignment nil alignp))

240

"Create a simple vector of length LENGTH and type ELEMENT-TYPE which will

241

not be moved by the garbage collector. The vector might be allocated in

242

foreign memory so you must always call FREE-STATIC-VECTOR to free it. Use

243

WITH-STATIC-VECTOR to handle this automatically."

244

(declare #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)

245

(optimize speed))

246

(check-arguments length element-type initial-element initial-element-p

247

initial-contents initial-contents-p)

248

(when alignp

249

;; Check that the alignment is a power of 2 beteeen 16 and 4096.

250

#+(and sbcl unix)

251

(assert (and (<= +default-alignment+ alignment +max-alignment+)

252

(= 1 (logcount alignment))))

253

#-(and sbcl unix)

254

(error "Allocation alignment not supported on this implementation."))

255

;; TODO: fix %allocate-static-vector for all implementations

256

(let ((vector

257

(%allocate-static-vector length element-type

258

(or alignment +default-alignment+))))

259

(if initial-element-p

260

(fill vector initial-element)

261

(replace vector initial-contents))))

262

263

(defmacro with-static-vector ((var length &rest args

264

&key (element-type ''(unsigned-byte 8))

265

initial-contents initial-element)

266

&body body &environment env)

267

"Bind VAR to a static vector of length LENGTH and execute BODY

268

within its dynamic extent. The vector is freed upon exit."

269

(declare (ignorable element-type initial-contents initial-element))

270

(multiple-value-bind (real-element-type length type-spec)

271

(canonicalize-args env element-type length)

272

(let ((args (copy-list args)))

273

(remf args :element-type)

274

`(sb-sys:without-interrupts

275

(let ((,var (make-static-vector ,length ,@args

276

:element-type ,real-element-type)))

277

(declare (type ,type-spec ,var))

278

(unwind-protect

279

(sb-sys:with-local-interrupts ,@body)

280

(when ,var (free-static-vector ,var))))))))

281

282

(defmacro with-static-vectors (((var length &rest args) &rest more-clauses)

283

&body body)

284

"Allocate multiple static vectors at once."

285

`(with-static-vector (,var ,length ,@args)

286

,@(if more-clauses

287

`((with-static-vectors ,more-clauses

288

,@body))

289

body)))

290

291

;;; Static Streams

292

293

;; Partially inspired by ELEPHANT's BUFFER-STREAM which provides accessors

294

;; written in C and provides a Lisp API but not an intermediate Lisp data

295

;; representation - unlike STATIC-VECTORs. It's worth trying the C-based

296

;; approach and comparing in the future - I think it's faster but less

297

;; convenient.

298

299

(defvar *default-static-stream-size* 100)

300

301

(defclass static-stream (io-stream sb-gray:fundamental-stream)

302

((buffer :initform (make-static-vector *default-static-stream-size*)

303

:initarg :buffer

304

:accessor buffer)

305

(offset :initform 0

306

:initarg :offset

307

:accessor offset))

308

(:documentation

309

"A stream backed by a STATIC-VECTOR."))

310

311

(defmethod sap ((self static-stream))

312

(static-vector-address (buffer self)))

313

314

(defmethod sb-sequence:length ((self static-stream)) (length (buffer self)))

315

316

(defmethod sb-gray:stream-file-position ((stream static-stream) &optional spec)

317

(if spec

318

(setf (offset stream) spec)

319

(offset spec)))

320

321

(defmethod sb-gray:stream-read-byte ((stream static-stream))

322

(prog1 (deref (sap-alien (static-vector-pointer (buffer stream)) (* unsigned-char)))

323

(incf (offset stream))))

324

325

(defmethod sb-gray:stream-read-char ((stream static-stream))

326

(prog1 (deref (sap-alien (static-vector-pointer (buffer stream)) (* char)))

327

(incf (offset stream))))

328

329

(defmethod sb-gray:stream-read-sequence ((stream static-stream) (seq sequence)

330

&optional (start 0)

331

end)

332

(if (= (1- (offset stream)) (length (buffer stream)))

333

start

334

(let ((inc (if end

335

(- end start)

336

(length seq))))

337

(coerce (subseq (buffer stream)

338

(offset stream)

339

inc)

340

(type-of seq))

341

(incf (offset stream) inc))))

342

343

(defmethod sb-gray:stream-write-byte ((stream static-stream) n)

344

(prog1 (setf (aref (buffer stream) (offset stream)) n)

345

(incf (offset stream))))

346

347

(defmethod sb-gray:stream-write-char ((stream static-stream) n)

348

(setf (aref (buffer stream) (offset stream)) n))

349

350

(defmethod sb-gray:stream-write-sequence ((stream static-stream) (seq sequence)

351

&optional (start 0)

352

                                                     (end (length seq)))

353

(replace (buffer stream) seq :start1 (offset stream) :start2 start :end2 end))

354

355

(defmethod close ((stream static-stream) &key abort)

356

(declare (ignore abort))

357

(free-static-vector (buffer stream)))

358

359

(defmethod sb-gray:stream-write-string ((stream static-stream) string &optional start end)

360

(sb-gray:stream-write-sequence stream (sb-ext:string-to-octets string) start end))

361

362

(defmethod sb-gray:stream-peek-char ((stream static-stream))

363

(aref (buffer stream) (offset stream)))

364

365

(defmethod sb-gray:stream-unread-char ((stream static-stream) char)

366

;; we ignore the value and always DECF the offset

367

(declare (ignore char))

368

(decf (offset stream)))

369

370

(defmacro with-static-stream ((var &rest args

371

&key (element-type ''(unsigned-byte 8))

372

(size *default-static-stream-size*)

373

initial-contents

374

initial-element)

375

&body body &environment env)

376

"Bind VAR to a static stream with an internal static vector buffer and execute BODY

377

within its dynamic extent. The static vector is freed upon exit."

378

(declare (ignorable element-type initial-contents initial-element))

379

(multiple-value-bind (real-element-type size)

380

(canonicalize-args env element-type size)

381

(let ((args (copy-list args)))

382

(remf args :element-type)

383

(remf args :size)

384

`(sb-sys:without-interrupts

385

(with-open-stream (,var

386

(make-instance 'static-stream

387

:buffer (make-static-vector ,size ,@args

388

                                                             :element-type ,real-element-type)))

389

(declare (type static-stream ,var))

390

(unwind-protect

391

(sb-sys:with-local-interrupts ,@body)))))))

392

393

(defmacro with-static-streams (((var &rest args) &rest more-clauses)

394

&body body)

395

"Allocate multiple static streams at once."

396

`(with-static-stream (,var ,@args)

397

,@(if more-clauses

398

`((with-static-streams ,more-clauses

399

,@body))

400

body)))