Coverage report: /home/ellis/comp/core/lib/rt/tracing.lisp

Kind	Covered	All	%
expression	90	484	18.6
branch	0	20	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; lib/rt/tracing.lisp --- Tracing Framework

2

3

;; This package provides utilities for tracing Lisp code and

4

;; displaying traces to the user. In addition to extending the

5

;; built-in TRACE macro and SB-DEBUG functionality we have a tracer

6

;; which works with Chrome's built-in tracer: chrome://trace.

7

8

;; The chrome tracer is a slightly modernized version of TeMPOraL's

9

;; work available here: https://github.com/TeMPOraL/tracer.

10

11

;; ref: https://www.chromium.org/developers/how-tos/trace-event-profiling-tool/

12

13

;; - sb-debug manual: https://www.sbcl.org/manual/#Debugger

14

15

;; - sb-debug notes: https://gist.github.com/nikodemus/659495

16

17

;;; Code:

18

(in-package :rt/tracing)

19

20

(defmacro traced-flet (functions &body body)

21

(flet ((add-traces (function)

22

(destructuring-bind

23

(name lambda-list &body body) function

24

`(,name ,lambda-list

25

,@(cons `(format t

26

"Calling ~a with ~@{~a=~a, ~}~%"

27

',name

28

,@(loop for symbol in lambda-list

29

collecting `(quote ,symbol)

30

collecting symbol))

31

body)))))

32

`(flet ,(mapcar #'add-traces functions) ,@body)))

33

34

;;; This is an implementation of a chromium-based Lisp tracer authored

35

;;; by TeMPOraL. The source is available here:

36

;;; https://github.com/TeMPOraL/tracer/tree/master

37

38

(defvar *trace-events* nil "A list of trace entries, pushed onto from the beginning.")

39

40

 (defvar *original-trace-start-breakpoint-fun* #'sb-debug::trace-start-breakpoint-fun "Original SBCL function being overwritten by the tracer.")

41

 (defvar *original-trace-end-breakpoint-fun* #'sb-debug::trace-end-breakpoint-fun "Original SBCL function being overwritten by the tracer.")

42

43

(defvar *clock-reset-fun* nil)

44

(defvar *clock-get-time-fun* nil)

45

46

 (defvar *trace-event-default-pid* 1 "The default value for PID for the trace events. This library is currently intended for use within a single process only.")

47

48

(defvar +arg-converter-ignore-all+ (constantly nil) "A converter that rejects all parameters.")

49

 (defvar +arg-converter-passthrough+ (lambda (&rest args) args) "A converter that remembers all args as is, without modifying them.")

50

(defvar +arg-converter-store-only-simple-objects+ (lambda (&rest args)

51

                                                     (mapcar (lambda (arg)

52

                                                               (typecase arg

53

                                                                 ((or boolean character number symbol)

54

                                                                  arg)

55

(t

56

                                                                  (type-of arg))))

57

                                                             args))

58

   "A converter that remembers directly only objects of simple types, that cannot or are very unlikely to be destructively modified.")

59

(defvar +arg-converter-store-only-simple-objects-and-strings+ (lambda (&rest args)

60

                                                                 (mapcar (lambda (arg)

61

                                                                           (typecase arg

62

                                                                             ((or boolean character number symbol string)

63

                                                                              arg)

64

(t

65

                                                                              (type-of arg))))

66

                                                                         args))

67

   "Like `+ARG-CONVERTER-STORE-ONLY-SIMPLE-OBJECTS+', but also records strings as-is, hoping they don't get destructively modified too much.")

68

69

(defvar *default-arg-converter* +arg-converter-ignore-all+)

70

(defvar *tracing-arg-converters* (make-hash-table :test 'equal))

71

72

 ;;; The format of trace event; created primarily for reference, though later on we might upgrade to vector storage, and then it'll come helpful.

73

(defstruct (trace-event (:type list))

74

"A single event being traced. "

75

(phase :undefined :type keyword)

76

(name nil :type (or symbol cons))

77

(thread 0 :type t)

78

(timestamp 0 :type fixnum)

79

(args nil :type t)

80

(duration 0 :type (or null (unsigned-byte 62)))

81

(id nil :type t))

82

83

 ;;; TODO: define accessors manually, to save performance? or somehow optimize it.  -- Jacek Złydach, 2019-11-04

84

85

(declaim (inline convert-args))

86

(defun convert-args (traced-fn-name args)

87

   "Depending on the function being traced, named `TRACED-FN-NAME', and the value of `*DEFAULT-ARG-CONVERTER*'

88

 convert the list of arguments `ARGS' to a form suitable for storing with the trace event, using a converter

89

registered under `*TRACING-ARG-CONVERTERS*'.

90

Returns the representation of `ARGS' to store."

91

(declare (optimize (speed 3)))

92

(apply (the function (gethash traced-fn-name *tracing-arg-converters* *default-arg-converter*))

93

args))

94

95

(declaim (inline make-trace-event-fast))

96

(defun make-trace-event-fast (phase name thread timestamp args duration id)

97

"Like `MAKE-TRACE-EVENT', but inlined, unsafe and without typechecking."

98

(declare (optimize (speed 3)))

99

(list phase name thread timestamp (convert-args name args) duration id))

100

101

;;; Timer

102

103

;;; TODO: make it so that user can plug a high-resolution timer here. -- Jacek Złydach, 2019-10-18

104

105

(sb-ext:defglobal *hack-clock-jitter* 0 "A crude hack because our clock has too little resolution.")

106

(declaim (type fixnum *hack-clock-jitter*))

107

108

;;; TODO: this needs to be a function that can be changed between invocations of tracing!

109

;;; I want to allow for injecting higher resolution clocks if available.

110

;;; -- Jacek Złydach, 2019-11-01

111

112

(defun get-current-time-usec* ()

113

"Get current time with microsecond resolution."

114

(sb-ext:atomic-incf *hack-clock-jitter*)

115

(the (unsigned-byte 62)

116

(+ (* (get-internal-real-time) 1000)

117

*hack-clock-jitter*)))

118

119

(declaim (ftype (function () (unsigned-byte 62)) get-current-time-usec*)

120

(inline get-current-time-usec*))

121

(defun get-current-time-usec-nojitter ()

122

"Get current time with microsecond resolution. No extra jitter involved."

123

(declare (optimize (speed 3)))

124

(the (unsigned-byte 62) (* (get-internal-real-time) 1000)))

125

126

;;; XXX: below is our new, usec clock -- Jacek Złydach, 2019-11-02

127

(let ((clock-offset 0))

128

(declare (type (unsigned-byte 62) clock-offset))

129

(defun %%start-clock ()

130

(setf clock-offset (sb-kernel::get-time-of-day)))

131

(defun %%get-time-usec ()

132

(multiple-value-bind (sec usec)

133

(sb-kernel::get-time-of-day)

134

(+ (* (- sec clock-offset) 1000000) usec)))

135

(defun %%time (thunk)

136

(let ((start (%%get-time-usec)))

137

(funcall thunk)

138

(- (%%get-time-usec) start)))

139

(setf *clock-reset-fun* #'%%start-clock

140

*clock-get-time-fun* #'%%get-time-usec))

141

142

(declaim (ftype (function () (values (unsigned-byte 62) &optional)) get-current-time)

143

(inline get-current-time))

144

(defun get-current-time ()

145

(funcall *clock-get-time-fun*))

146

147

(defun post-process-entries (entries &key correct-zero-duration)

148

"Destructively modify `ENTRIES', making it more compact and, if `CORRECT-ZERO-DURATION' is T,

149

changing zero-length events to have 1us length, also modifying other times to offset for that.

150

 `ENTRIES' is expected to be in order entries were added. The function maintain separate offsets per (process, thread) pair.

151

 Returns a processed list, to replace old value `ENTRIES'. As additional values, returns the total accumulated clock offset,

152

and the stacks containing unclosed duration entries, keyed by thread."

153

(let ((offset 0)

154

(stacks (make-hash-table :test 'equal)))

155

(dolist (entry entries entries)

156

;; Always update event time to account for clock offset.

157

(incf (trace-event-timestamp entry) offset)

158

159

       ;; Match starting and ending events to offset clock in case of zero-length events, and to convert

160

;; matching pairs of Duration events into Complete events.

161

(let ((entry-ht-id (cons 1 (trace-event-thread entry)))) ;1 is the currently supported PID

162

(ecase (trace-event-phase entry)

163

(:enter

164

;; Push the :enter entry to stack.

165

(push entry (gethash entry-ht-id stacks)))

166

(:exit

167

(let ((begin-event (first (gethash entry-ht-id stacks))))

168

(if (equalp (trace-event-name begin-event)

169

(trace-event-name entry))

170

(progn

171

;; Actual post-processing happens here.

172

                    ;; If zero-length and correct-zero-duration is on, update close time and offset.

173

(when (and correct-zero-duration

174

(= (trace-event-timestamp begin-event)

175

(trace-event-timestamp entry)))

176

(incf (trace-event-timestamp entry))

177

(incf offset))

178

179

;; Convert task into complete task + counter

180

(setf (trace-event-phase begin-event) :complete

181

                          (trace-event-phase entry) :skip ;TODO: counters, if any, go here -- Jacek Złydach, 2019-11-04

182

                          (trace-event-duration begin-event) (- (trace-event-timestamp entry) (trace-event-timestamp begin-event))

183

                          (trace-event-args begin-event) `(:in ,(trace-event-args begin-event) :out ,(trace-event-args entry)))

184

185

;; Pop the updated entry from stack.

186

(pop (gethash entry-ht-id stacks)))

187

                  (warn "Recorded entries misordered; expected ~A, got ~A." (trace-event-name begin-event) (trace-event-name entry))))))))

188

;; Go over the list again, and remove "skip" entries.

189

(deletef entries :skip :key #'trace-event-phase)

190

(values entries

191

offset

192

stacks)))

193

194

;;; Tracing process

195

196

(defun %trace-start-breakpoint-fun (info)

197

(let (conditionp)

198

(values

199

(lambda (frame bpt &rest args)

200

(declare (ignore bpt))

201

(sb-debug::discard-invalid-entries frame)

202

(let ((condition (sb-debug::trace-info-condition info))

203

(wherein (sb-debug::trace-info-wherein info)))

204

(setq conditionp

205

(and (not sb-debug::*in-trace*)

206

(or (not condition)

207

(apply (cdr condition) frame args))

208

(or (not wherein)

209

(sb-debug::trace-wherein-p frame wherein nil)))))

210

(when conditionp

211

(when (sb-debug::trace-info-encapsulated info)

212

(sb-ext:atomic-push (make-trace-event-fast :enter

213

                                                       (sb-debug::trace-info-what info)

214

                                                       sb-thread:*current-thread*

215

                                                       (get-current-time)

216

args

217

nil

218

nil)

219

*trace-events*))

220

;; TODO: perhaps remove this, it seems unneeded -- Jacek Złydach, 2019-11-05

221

(with-standard-io-syntax

222

(apply #'sb-debug::trace-maybe-break info (sb-debug::trace-info-break info) "before"

223

frame args))))

224

(lambda (frame cookie)

225

(declare (ignore frame))

226

(push (cons cookie conditionp) sb-debug::*traced-entries*)))))

227

228

(declaim (ftype (function (sb-debug::trace-info) function) %trace-end-breakpoint-fun))

229

(defun %trace-end-breakpoint-fun (info)

230

(lambda (frame bpt values cookie)

231

(declare (ignore bpt))

232

(unless (eq cookie (caar sb-debug::*traced-entries*))

233

(setf sb-debug::*traced-entries*

234

(member cookie sb-debug::*traced-entries* :key #'car)))

235

236

(let ((entry (pop sb-debug::*traced-entries*)))

237

(when (and (not (sb-debug::trace-info-untraced info))

238

(or (cdr entry)

239

(let ((cond (sb-debug::trace-info-condition-after info)))

240

(and cond (apply #'funcall (cdr cond) frame values)))))

241

(sb-ext:atomic-push (make-trace-event-fast :exit

242

                                                    (sb-debug::trace-info-what info)

243

                                                    sb-thread:*current-thread*

244

                                                    (get-current-time)

245

values

246

nil

247

nil)

248

*trace-events*)

249

250

(apply #'sb-debug::trace-maybe-break info (sb-debug::trace-info-break-after info) "after"

251

frame values)))))

252

253

(defun install-tracing-overrides ()

254

(sb-ext:unlock-package (find-package 'sb-debug))

255

(setf (symbol-function 'sb-debug::trace-start-breakpoint-fun) #'%trace-start-breakpoint-fun

256

(symbol-function 'sb-debug::trace-end-breakpoint-fun) #'%trace-end-breakpoint-fun)

257

(sb-ext:lock-package (find-package 'sb-debug)))

258

259

(defun uninstall-tracing-overrides ()

260

(sb-ext:unlock-package (find-package 'sb-debug))

261

(setf (symbol-function 'sb-debug::trace-start-breakpoint-fun) *original-trace-start-breakpoint-fun*

262

(symbol-function 'sb-debug::trace-end-breakpoint-fun) *original-trace-end-breakpoint-fun*)

263

(sb-ext:lock-package (find-package 'sb-debug)))

264

265

(defun start-tracing (specs)

266

(install-tracing-overrides)

267

`(progn

268

(trace :encapsulate :default :methods t ,@specs)))

269

270

(defun stop-tracing ()

271

(untrace)

272

(uninstall-tracing-overrides)

273

#+nil(setf *trace-events* (nreverse *trace-events*))

274

(multiple-value-bind (events offset stacks)

275

(post-process-entries (nreverse *trace-events*))

276

(declare (ignore offset stacks))

277

(setf *trace-events* events))

278

;; TODO: report offsets and stacks -- Jacek Złydach, 2019-11-05

279

(values))

280

281

(defun reset-tracing ()

282

(setf *trace-events* nil

283

*hack-clock-jitter* 0))

284

285

(defun get-tracing-report-data ()

286

*trace-events*)

287

288

;;; Trace operations:

289

;;; 1. Reset

290

;;; 2. Trace

291

;;; 2.5 snapshot tracing?

292

;;; 3. Stop tracing

293

;;; 4. Save report

294

295

(defvar *tracing-p* nil "Is currently tracing activity happening?")

296

297

;;; Trace info entry type, for function call

298

;;; - Timestamp

299

;;; - Function name

300

;;; - Function args maybe? (trace-with-args), on enter

301

;;; - Function return value, on exit

302

;;; - Beginning or ending

303

;;; - Thread ID

304

305

;;; This prints a representation of the return values delivered.

306

;;; First, this checks to see that cookie is at the top of

307

;;; *TRACED-ENTRIES*; if it is not, then we need to adjust this list

308

;;; to determine the correct indentation for output. We then check to

309

;;; see whether the function is still traced and that the condition

310

;;; succeeded before printing anything.

311

312

(defmacro with-tracing (specs &body body)

313

`(unwind-protect

314

(progn

315

(reset-tracing)

316

(start-tracing ',specs)

317

(progn

318

,@body))

319

(stop-tracing)))

320

321

(defun function-name->name-and-category (function-name)

322

(etypecase function-name

323

(symbol

324

(values (symbol-name function-name) (package-name (symbol-package function-name))))

325

(cons

326

(ecase (first function-name)

327

(setf

328

         (values (format nil "~S" function-name) (package-name (symbol-package (second function-name)))))

329

;; TODO investigate

330

((method sb-pcl::combined-method)

331

(values (remove #\Newline (format nil "~S" function-name))

332

(if (consp (second function-name))

333

(package-name (symbol-package (second (second function-name))))

334

(package-name (symbol-package (second function-name))))))))))

335

336

(defgeneric post-process-arg (arg)

337

(:method ((arg t))

338

"Passthrough method."

339

(or (ignore-errors

340

(prin1-to-string arg))

341

"!!Error printing argument!!"))

342

(:documentation "A hook useful for changing the printed representation of input and return values."))

343

344

(defmethod post-process-arg ((arg sequence))

345

(if (every (lambda (el) (typep el 'number)) arg)

346

(format nil "[~{~F~^, ~}]" (coerce arg 'list))

347

(call-next-method)))

348

349

 ;;; FIXME: Something breaks if not collecting args, and :skip-args is NIL. Probably the getf in printing. -- Jacek Złydach, 2019-11-05

350

(defun trace-event->json (trace-event &key (skip-args nil))

351

(flet ((sanitize-and-format-args-list (argslist)

352

(if skip-args "\"_\""

353

                (substitute #\Space #\Newline (format nil "[~{~S~^, ~}]" (mapcar #'post-process-arg argslist))))))

354

(ecase (trace-event-phase trace-event)

355

(:enter

356

(multiple-value-bind (name category)

357

(function-name->name-and-category (trace-event-name trace-event))

358

(format nil

359

                  "{ \"name\" : ~S, \"cat\" : ~S, \"ph\" : \"B\", \"pid\" : 1, \"tid\" : ~D, \"ts\" : ~D, \"args\" : { \"in\" : ~A }}"

360

name

361

category

362

(sb-impl::get-lisp-obj-address (trace-event-thread trace-event))

363

(trace-event-timestamp trace-event)

364

(sanitize-and-format-args-list (trace-event-args trace-event)))))

365

(:exit

366

(multiple-value-bind (name category)

367

(function-name->name-and-category (trace-event-name trace-event))

368

(format nil

369

                  "{ \"name\" : ~S, \"cat\" : ~S, \"ph\" : \"E\", \"pid\" : 1, \"tid\" : ~D, \"ts\" : ~D, \"args\" : { \"out\" : ~A }}"

370

name

371

category

372

(sb-impl::get-lisp-obj-address (trace-event-thread trace-event))

373

(trace-event-timestamp trace-event)

374

(sanitize-and-format-args-list (trace-event-args trace-event)))))

375

(:complete

376

(multiple-value-bind (name category)

377

(function-name->name-and-category (trace-event-name trace-event))

378

(format nil

379

                  "{ \"name\" : ~S, \"cat\" : ~S, \"ph\" : \"X\", \"pid\" : 1, \"tid\" : ~D, \"ts\" : ~D, \"dur\" : ~D,  \"args\" : { \"in\" : ~A, \"out\" : ~A }}"

380

name

381

category

382

(sb-impl::get-lisp-obj-address (trace-event-thread trace-event))

383

(trace-event-timestamp trace-event)

384

(trace-event-duration trace-event)

385

(sanitize-and-format-args-list (getf (trace-event-args trace-event) :in))

386

(sanitize-and-format-args-list (getf (trace-event-args trace-event) :out))))))))

387

388

(defun thread->json (thread)

389

(format nil

390

           "{ \"name\" : \"thread_name\", \"ph\" : \"M\", \"pid\" : 1, \"tid\" : ~D, \"args\" : { \"name\" : ~S }}"

391

(sb-impl::get-lisp-obj-address thread)

392

(sb-thread:thread-name thread)))

393

394

(defun extract-threads (events)

395

(loop

396

with uniques-ht = (make-hash-table :test #'eq)

397

for event in events

398

do

399

(setf (gethash (trace-event-thread event) uniques-ht) t)

400

finally

401

(return (hash-table-keys uniques-ht))))

402

403

;;; FIXME: save with streams instead? -- Jacek Złydach, 2019-10-14

404

(defun save-report (output-file-name &key (skip-args t))

405

(with-open-file (stream output-file-name :direction :output :if-exists :supersede)

406

;; TODO: preamble -- Jacek Złydach, 2019-10-14

407

(format stream "{~%\"traceEvents\" : [~%")

408

(loop

409

for (entry . restp) on *trace-events*

410

do

411

(write-string (trace-event->json entry :skip-args skip-args) stream)

412

(when restp

413

(write-string "," stream)

414

(terpri stream)))

415

(loop

416

for (thread . restp) on (extract-threads *trace-events*)

417

initially

418

(write-string "," stream)

419

(terpri stream)

420

do

421

(write-string (thread->json thread) stream)

422

(when restp

423

(write-string "," stream)

424

(terpri stream)))

425

426

(format stream "~&],

427

\"displayTimeUnit\" : \"ms\",

428

\"application\" : \"FIXME\",

429

\"version\" : \"FIXME\",

430

\"traceTime\" : ~S

431

}"

432

(time:format-timestring nil (time:now))

433

))

434

(values))

435

��