Coverage report: /home/ellis/comp/core/std/sys.lisp

Kind	Covered	All	%
expression	12	476	2.5
branch	1	36	2.8

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; std/sys.lisp --- Lisp System Utilities

2

3

;;

4

5

;;; Code:

6

(in-package :std/sys)

7

8

;;; Introspection

9

;; (reexport-from :sb-introspect

10

;; :include '(:function-lambda-list :lambda-list-keywords :lambda-parameters-limit

11

;; :method-combination-lambda-list :deftype-lambda-list

12

;; :primitive-object-size :allocation-information

13

;; :function-type

14

;; :who-specializes-directly :who-specializes-generally

15

;; :find-function-callees :find-function-callers))

16

17

;; sys

18

;; sb-sys:*linkage-info* *machine-version* *runtime-dlhandle* *periodic-polling-function*

19

 ;; *periodic-polling-period* io-timeout nlx-protect serve-event os-deinit os-exit with-deadline dlopen-or-lose deallocate-system-memory

20

21

(defvar *interactive* t

22

"When non-nil (the default) specifies that this is an interactive REPL session

23

and we may query the user for input.")

24

25

(define-symbol-macro .i sb-ext:*inspected*)

26

27

(defun hooks ()

28

"Return the standard list of system hooks."

29

(list

30

:init sb-ext:*init-hooks*

31

:after-gc sb-ext:*after-gc-hooks*

32

:save sb-ext:*save-hooks*

33

:exit sb-ext:*exit-hooks*))

34

35

(defparameter *default-arena-size* (* 10 1024 1024 1024)

36

"The default size of freshly allocated arenas.")

37

38

(defparameter *default-heap-size* (ash 1 16)

39

"The default system heap size.")

40

41

(defun current-lisp-implementation ()

42

"Return the current lisp implemenation as a list: (TYPE VERSION FEATURES)"

43

(list

44

(lisp-implementation-type)

45

(lisp-implementation-version)

46

*features*))

47

48

(defun current-machine ()

49

"Return the current machine spec as a list: (HOST TYPE VERSION)"

50

(list

51

(machine-instance)

52

(machine-type)

53

(machine-version)))

54

55

(defun list-package-symbols (&optional (pkg *package*))

56

"List all external symbols of PKG."

57

(loop for s being the external-symbol of pkg

58

collect s))

59

60

(defun list-all-symbols ()

61

"List all symbols found in this iamge."

62

(let ((r))

63

(dolist (p (list-all-packages) r)

64

(appendf r (list-package-symbols p)))))

65

66

(defun package-symbols (&optional (package *package*) test)

67

"List the symbols of PACKAGE which satisfy TEST if present."

68

(let ((symbols))

69

(do-external-symbols (symbol package)

70

(if test

71

(when (funcall test symbol)

72

(push symbol symbols))

73

(push symbol symbols)))

74

symbols))

75

76

(defun package-symbol-names (&optional (package *package*) test)

77

"List the symbol names of PACKAGE which satisfy test if present."

78

(sort (mapcar (lambda (x) (string-downcase (symbol-name x)))

79

(package-symbols package test))

80

#'string<))

81

82

(defmacro do-internal-symbols ((var package) &body forms)

83

"Bind VAR to each internal symbol of PACKAGE in turn and evaluating FORMS for each."

84

(std/sym:with-gensyms (state)

85

`(do-symbols (,var ,package)

86

(multiple-value-bind (,var ,state)

87

(find-symbol (symbol-name ,var) ,package)

88

(when (eq ,state :internal)

89

,@forms)))))

90

91

(defun standard-symbol-names (&optional test)

92

"List the ANSI standard list of symbols which satisfy TEST if present."

93

(package-symbol-names :common-lisp test))

94

95

(defun handle-serious-condition (condition)

96

"Handle a fatal CONDITION. Depending on whether *INTERACTIVE* is set, enter

97

debug or die."

98

(cond

99

(*interactive*

100

(invoke-debugger condition))

101

(t

102

(with-sane-io-syntax

103

(let ((out (make-synonym-stream '*error-output*)))

104

(format out "~&Fatal condition:~%~A~%" condition)

105

(sb-debug:print-backtrace :stream out))

106

(when condition

107

(format t "~A" condition)

108

(sb-ext:quit :unix-status 99))))))

109

110

(eval-always

111

(defvar *core-image-revived-p* nil

112

"Set to T when the current image has been revived.")

113

(defvar *core-image-revive-hooks* nil

114

"List of hooks to be evaluated when an image is revived.")

115

(defvar *core-image-entry-point* nil

116

"Entrypoint associated with this core image."))

117

118

(defun revive-image (&key (interactive *interactive*)

119

(hooks *core-image-revive-hooks*)

120

(entry-point *core-image-entry-point*)

121

(if-already-revived '(cerror "Revive image anyway")))

122

"Like UIOP:RESTORE-IMAGE but without a prelude."

123

(when *core-image-revived-p*

124

(if if-already-revived

125

(funcall if-already-revived "Image already ~:[being ~;~]revived"

126

(eq *core-image-revived-p* t))

127

(return-from revive-image)))

128

(handler-bind ((serious-condition #'handle-serious-condition))

129

(setf *interactive* interactive)

130

(setf *core-image-revive-hook* hooks)

131

(setf *core-image-revived-p* :in-progress)

132

(dolist (f *core-image-revive-hooks*)

133

(funcall f))

134

(setf *core-image-revived-p* t)

135

(let ((results (multiple-value-list

136

(if entry-point

137

(funcall entry-point)

138

t))))

139

(if interactive

140

(values-list results)

141

(sb-ext:exit :code (if (first results) 0 1))))))

142

143

;; HACK 2025-06-10: this attempts to modify read-only memory - can we arrange

144

;; for the read-only mem to be replaced on save?

145

146

;; Remove all symbols from all packages, storing them in weak pointers,

147

;; then collect garbage, and re-intern all symbols that survived GC.

148

;; Any symbol satisfying PREDICATE will be strongly referenced during GC

149

;; so that it doesn't disappear, regardless of whether it appeared unused.

150

(in-package :sb-impl)

151

(defun shake-packages (predicate &key print verbose query)

152

"WIP Tree Shaker"

153

(declare (function predicate))

154

(let (list)

155

(flet ((weaken (table accessibility)

156

(let ((cells (symtbl-cells table))

157

(result))

158

(dovector (x cells)

159

(when (symbolp x)

160

(if (funcall predicate x accessibility)

161

(push x result) ; keep a strong reference to this symbol

162

(push (cons (string x) (make-weak-pointer x)) result))))

163

(fill cells 0)

164

(resize-symbol-table table 0 'intern)

165

result)))

166

(dolist (package (list-all-packages))

167

;; Never discard standard symbols

168

(unless (eq package sb-int:*cl-package*)

169

(push (list* (weaken (package-internal-symbols package) :internal)

170

(weaken (package-external-symbols package) :external)

171

package)

172

list))))

173

(gc :gen 7)

174

(when query

175

(sb-ext:search-roots query :criterion :static))

176

(let ((n-dropped 0))

177

(flet ((reintern (symbols table package access)

178

(declare (ignore package))

179

(dolist (item symbols)

180

(if (symbolp item)

181

(add-symbol table item 'intern)

182

(let ((symbol (weak-pointer-value (cdr item))))

183

(cond (symbol

184

(add-symbol table symbol 'intern))

185

(t

186

(when print

187

(format t " (~a)~A~%" access (car item)))

188

(incf n-dropped))))))))

189

(loop for (internals externals . package) in list

190

do (when print

191

(format t "~&Package ~A~%" package))

192

(reintern internals (package-internal-symbols package)

193

package #\i)

194

(reintern externals (package-external-symbols package)

195

package #\e))

196

(when verbose

197

(format t "~&Dropped ~D symbols~%" n-dropped))

198

(force-output)))))

199

200

(in-package :std/sys)

201

202

;; TODO

203

(defun save-lisp-tree-shake-and-die (path &rest args)

204

"A naive tree-shaker for lisp."

205

;; https://gist.github.com/burtonsamograd/f08f561264ff94391300

206

(loop repeat 10

207

do (sb-ext:gc :full t))

208

(apply #'sb-ext:save-lisp-and-die path args))

209

210

(defparameter *gc-logfile* #P"gc.log")

211

212

(defun enable-gc-logfile (&optional (file *gc-logfile*))

213

"Enable the system *GC-LOGFILE*."

214

(setf (sb-ext:gc-logfile) file))

215

216

(defun forget-shared-object (name)

217

"Forget the shared object specified by NAME."

218

(setf (sb-alien::shared-object-dont-save

219

(find name sb-sys:*shared-objects*

220

:key 'sb-alien::shared-object-namestring

221

:test 'string-equal))

222

t))

223

224

(defun forget-shared-objects (&optional (objects sb-sys:*shared-objects*))

225

"Set the DONT-SAVE slot of all objects in SB-SYS:*SHARED-OBJECTS* to T."

226

(mapcar (lambda (obj) (setf (sb-alien::shared-object-dont-save obj) t)) objects))

227

228

(defun save-shared-objects (objects)

229

"Set the DONT-SAVE slot of OBJECTS to T."

230

(mapcar (lambda (obj) (setf (sb-alien::shared-object-dont-save obj) nil)) objects))

231

232

 (defun compile-lisp (name &key force save make package compression verbose version callable-exports executable (toplevel #'sb-impl::toplevel-init) forget save-runtime-options root-structures (purify t))

233

"Process NAME and keyword arguments then pass options to the underlying build

234

system - eventually terminating on SAVE-LISP-AND-DIE."

235

(pkg:with-package (or package *package*)

236

(asdf:compile-system name :force force :verbose verbose :version version)

237

(when make

238

(apply 'asdf:make name (unless (eq t make) make)))

239

(when forget

240

(forget-shared-objects (unless (eq t forget) forget)))

241

(when save

242

(when (probe-file save)

243

(delete-file save))

244

(sb-ext:save-lisp-and-die save :executable executable

245

:toplevel toplevel

246

:callable-exports callable-exports

247

:save-runtime-options save-runtime-options

248

:root-structures root-structures

249

:purify purify

250

:compression compression))))

251

252

(defmacro without-fp-traps (() &body body)

253

"Eval BODY with float traps disabled - sometimes necessary when working with

254

shared libraries."

255

`(sb-int:with-float-traps-masked (:invalid :divide-by-zero)

256

,@body))

257

258

259

 ;; https://www.intel.com/content/dam/develop/public/us/en/documents/10tb-24-breakthrough-aes-performance-with-intel-aes-new-instructions-final-secure.pdf

260

261

;; ncycles=(tscend-tscstart/i)

262

263

;; based on sb-simd-internals and https://kurohuku.blogspot.com/2009/11/sbclcpuid.html

264

265

;; also see https://github.com/jdmccalpin/low-overhead-timers/blob/master/low_overhead_timers.c

266

267

(defun cpuid (eax &optional (ecx 0))

268

"Call the CPUID instruction with supplied 32-bit values for EAX and ECX

269

regs. Returns 4 values containing the regs RAX RBX RCX and RDX respectively."

270

(declare ((unsigned-byte 32) eax ecx))

271

(sb-vm::%cpu-identification eax ecx))

272

273

(defun word-byte-list (n)

274

"Decompose a 32-bit integer N into 4 octets."

275

(declare ((unsigned-byte 32) n))

276

(list

277

(ldb (byte 8 0) n)

278

(ldb (byte 8 8) n)

279

(ldb (byte 8 16) n)

280

(ldb (byte 8 24) n)))

281

282

(macrolet ((%with-cpuid (n &body body)

283

`(multiple-value-bind (a b c d) (cpuid ,n)

284

,@body)))

285

(defun cpu-vendor ()

286

"Return the vendor of the host CPU."

287

(%with-cpuid 0

288

(declare (ignore a))

289

(coerce

290

(mapcan

291

#'(lambda (n)

292

(mapcar #'code-char (word-byte-list n)))

293

(list b d c))

294

'string)))

295

;; this is the same as MACHINE-VERSION

296

(defun cpu-brand ()

297

"Return the brand of the host CPU."

298

(with-output-to-string (s)

299

(dolist (n '#.(mapcar #'(lambda (x)

300

(coerce x '(unsigned-byte 32)))

301

(list #x80000002 #x80000003 #x80000004)))

302

(declare ((unsigned-byte 32) n))

303

(%with-cpuid n

304

(dolist (word (list a b c d))

305

(dolist (code (word-byte-list word))

306

(unless (zerop code)

307

(write-char (code-char code) s)))))))))

308

309

;; from stmx

310

(declaim (ftype (function () boolean) transaction-supported-p lock-elision-supported-p))

311

312

(defun lock-elision-supported-p ()

313

"Test for HLE, i.e. hardware lock elision.

314

HLE is supported if (cpuid 7) returns ebx with bit 4 set. If a processor does

315

not support HLE, it will ignore the new assembler instruction prefixes

316

XACQUIRE and XRELEASE.

317

318

As of June 2013, the only x86-64 CPUs supporting HLE are: * Intel Core i5 4570

319

* Intel Core i5 4670 * Intel Core i7 4770 Beware: at the time of writing all

320

the known K models, as for example Intel Core i7 4770K, do **NOT** support

321

HLE."

322

323

(let ((max-cpuid (cpuid 0)))

324

(when (>= max-cpuid 7)

325

(let ((ebx (nth-value 1 (cpuid 7))))

326

(not (zerop (logand ebx #x10)))))))

327

328

(defun transaction-supported-p ()

329

"Test for RTM, i.e. hardware memory transactions.

330

RTM is supported if (cpuid 7) returns ebx with bit 11 set. If a processor

331

does not support HLE, trying to execute the new assembler instructions XBEGIN,

332

XEND, XABORT and XTEST will generate faults.

333

334

As of June 2013, the only x86-64 CPUs supporting RTM are:

335

* Intel Core i5 4570

336

* Intel Core i5 4670

337

* Intel Core i7 4770

338

339

Beware: at the time of writing all the known K models, as for example Intel

340

Core i7 4770K, do **NOT** support RTM."

341

(let ((max-cpuid (cpuid 0)))

342

(when (>= max-cpuid 7)

343

(let ((ebx (nth-value 1 (cpuid 7))))

344

(not (zerop (logand ebx #x800)))))))

345

346

(defparameter %little-endian nil

347

"An internal flag which indicates the host is little-endian, in the event that

348

we can't determine endianness at compile-time.")

349

350

(defun little-endian-p ()

351

"Return T if the current platform is little-endian else NIL."

352

#+(or :x86 :x86-64 :little-endian) t

353

#+(or :PPC :POWERPC :big-endian) nil

354

#-(or :x86 :x86-64 :little-endian :ppc :powerpc :big-endian)

355

%little-endian)

356

357

(defun 64-bit-p ()

358

"Return T on a 64-bit platform else NIL."

359

#+x86-64 t)

360

(defun 32-bit-p ()

361

"Return T on a 64-bit platform else NIL."

362

#+x86 t)

363

364

(defun register-project-directory (path &optional (asdf t))

365

"Add PATH to QL:*LOCAL-PROJECT-DIRECTORIES* and ASDF:*CENTRAL-REGISTRY* (as

366

long as ASDF is non-nil)."

367

#+quicklisp (pushnew path ql:*local-project-directories*)

368

(when asdf (pushnew path asdf:*central-registry*)))

369

370

;;; Time

371

(definline get-real-time-seconds ()

372

"Call GET-INTERNAL-REAL-TIME and convert the result to seconds."

373

(/ (get-internal-real-time) internal-time-units-per-second))

374

375

(defun %time-remaining (start timeout)

376

"Check the current time to see if TIMEOUT seconds have elapsed since START."

377

(- timeout (- (get-real-time-seconds) start)))

378

379

(defmacro! with-countdown (o!time &body body)

380

"Eval BODY with an implicit timeout TIME."

381

(with-gensyms (start)

382

`(let ((,start (get-real-time-seconds)))

383

(flet ((time-remaining () (std/sys::%time-remaining ,start ,g!time)))

384

(declare (inline time-remaining))

385

,@body))))

386

387

;;; Logical Pathnames

388

(defun logical-host-names ()

389

"Print a list of currently available logical hosts."

390

(map 'list (lambda (x) (slot-value x 'sb-impl::name)) *logical-hosts*))

391

392

(defmacro define-logical-pathname (host path &rest translations)

393

"Define a new LOGICAL-PATHNAME associated with HOST and defaulting to

394

PATH. TRANSLATIONS is a list of (MATCH TRANSLATION) pairs."

395

(unless (null path)

396

(setf translations

397

(append `((,(format nil "~A" host) ,path)) translations)))

398

`(setf (logical-pathname-translations ,host)

399

;; eval second element only

400

',(mapcar (lambda (x)

401

(setf (cadr x) (eval (cadr x)))

402

x)

403

translations)))

404

405

(define-logical-pathname "STASH" "/opt/stash/"

406

("**;*.*.*" "/opt/stash/**/*.*"))

407

(define-logical-pathname "STORE" "/opt/store/"

408

("**;*.*.*" "/opt/store/**/*.*"))

409

(define-logical-pathname "SCRATCH" "/opt/scratch/"

410

("**;*.*.*" "/opt/scratch/**/*.*"))

411

;; redefine the sys table

412

(define-logical-pathname "SYS" "/usr/local/lib/sbcl/"

413

("SRC;**;*.*.*" #P"/usr/local/src/sbcl/src/**/*.*")

414

("CONTRIB;**;*.*.*"

415

#P"/usr/local/src/sbcl/contrib/**/*.*")

416

("OUTPUT;**;*.*.*"

417

(translate-logical-pathname "STASH:OUTPUT;sbcl;**;*.*.*"))

418

("TMP;**;*.*.*" "/tmp/**/*.*"))

419

420

;;; Hexdump

421

;; https://stackoverflow.com/questions/69974963/object-memory-layout-in-common-lisp#70019565

422

(defun hexdump-object (obj)

423

"Try to hexdump an object, including immediate objects. All the

424

work is done by sb-vm:hexdump in the interesting cases."

425

#-64-bit

426

(error "not a 64-bit SBCL")

427

(let* ((address/thing (sb-kernel:get-lisp-obj-address obj))

428

(tags (ldb (byte 4 0) address/thing)))

429

(format t "~&lowtags: ~12T~4,'0b~%" tags)

430

(cond

431

((zerop (ldb (byte 1 0) tags))

432

(format t "~&fixnum:~12T~16,'0x = ~S~%" address/thing obj))

433

((= (ldb (byte 2 0) tags) #b01)

434

(format t "~&immediate:~12T~16,'0x = ~S~%" address/thing obj))

435

((= (ldb (byte 2 0) tags) #b11) ;must be true

436

(format t "~&~A:~12T~16,'0x : ~16,'0x~%"

437

(case (ldb (byte 2 2) tags)

438

(#b00 "instance")

439

(#b01 "cons")

440

(#b10 "function")

441

(#b11 "other"))

442

address/thing (dpb #b0000 (byte 4 0) address/thing))

443

;; this tells you at least something (and really annoyingly

444

;; does not pad addresses on the left)

445

(sb-vm:hexdump obj))

446

;; can't happen

447

(t (error "mutant"))))

448

(values))