-
Notifications
You must be signed in to change notification settings - Fork 20
/
md-utilities.lisp
executable file
·249 lines (206 loc) · 8.82 KB
/
md-utilities.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
#|
Cells -- Automatic Dataflow Managememnt
(See defpackage.lisp for license and copyright notigification)
|#
(in-package :cells)
(defun md-awake (self) (eql :awake (md-state self)))
(defun fm-grandparent (md)
(fm-parent (fm-parent md)))
(defmethod md-release (other)
(declare (ignorable other)))
(export! mdead)
;___________________ birth / death__________________________________
(defgeneric mdead (self)
(:method ((self model-object))
(unless *not-to-be* ;; weird - let's folks function for not-to-be cleanup
(eq :eternal-rest (md-state self))))
(:method (self)
(declare (ignore self))
nil))
(export! *ntb-dbg*)
(defgeneric not-to-be (self)
(:method (other)
(declare (ignore other)))
(:method ((self cons))
(not-to-be (car self))
(not-to-be (cdr self)))
(:method ((self array))
(loop for s across self
do (not-to-be s)))
(:method ((self hash-table))
(maphash (lambda (k v)
(declare (ignorable k))
(not-to-be v)) self))
(:method ((self model-object))
(when *ntb-dbg*
(trcx not2be self)
(when (and *md-awake* (not (gethash self *md-awake*)))
(trcx not2be-not-awake!!!! self)))
(setf (md-census-count self) -1)
(md-quiesce self)
(md-awake-remove self))
(:method :before ((self model-object))
(loop for slot-name in (md-owning-slots self)
do (not-to-be (slot-value self slot-name))))
(:method :around ((self model-object))
(declare (ignorable self))
(let ((*not-to-be* t)
(dbg nil))
(flet ((gok ()
(if (or (eq (md-state self) :eternal-rest)
(md-doomed self))
(trc nil "n2be bailing already dead or doomed" self (md-state self)(md-doomed self))
(progn
(setf (md-doomed self) t)
(call-next-method)
(setf (fm-parent self) nil
(md-state self) :eternal-rest)
(md-awake-remove self)
(md-map-cells self nil
(lambda (c)
(c-assert (eq :quiesced (c-state c)) ()
"Cell ~a of dead model ~a not quiesced. Was not-to-be shadowed by
a primary method? Use :before instead." c self))) ;; fails if user obstructs not.to-be with primary method (use :before etc)
))))
(if (not dbg)
(gok)
(wtrc (0 100 "not.to-be nailing" self (when (typep self 'family)
(mapcar 'type-of (slot-value self '.kids))))
(gok)
(when dbg (trc "finished nailing" self))))))))
(defun md-quiesce (self)
#+xxxx (unless (search "QX-" (string (md-name self)))
(trc "md-quiescing" self (type-of self)(type-of (fm-parent self))))
(md-map-cells self nil (lambda (c)
(trc nil "quiescing" c)
(c-assert (not (find c *call-stack*)))
(c-quiesce c)))
(when (register? self)
(fm-check-out self)))
(defun c-quiesce (c)
(typecase c
(cell
(trc nil "c-quiesce unlinking" c)
(c-unlink-from-used c)
(dolist (caller (c-callers c))
(setf (c-value-state caller) :uncurrent)
(trc nil "c-quiesce totlalaly unlinking caller and making uncurrent" .dpid :q c :caller caller)
(c-unlink-caller c caller))
(setf (c-state c) :quiesced) ;; 20061024 for debugging for now, might break some code tho
)))
(defparameter *to-be-dbg* nil)
(defmacro make-kid (class &rest ia)
(with-gensyms (c)
`(let ((,c ,class))
(make-instance ,c
,@ia
:fm-parent (progn (assert self () "make-kid: self nil making ~a" ,c)
self)))))
(defvar *c-d-d*)
(defvar *max-d-d*)
(defparameter *model-pop* nil)
(export! md-census-start md-census-report md-census-count)
(defun md-census-start ()
(setf *model-pop* (make-hash-table :test 'eq)))
(defun (setf md-census-count) (delta self)
(when *model-pop*
(incf (gethash (type-of self) *model-pop* 0) delta)
#-its-alive!
(when (minusp (gethash (type-of self) *model-pop* 0))
(warn "minus pop ~a" self))))
(defun md-census-report ()
(when *model-pop*
(loop for (ct . type)
in (sort (let (raw)
(maphash (lambda (k v)
(push (cons v k) raw))
*model-pop*)
raw) '< :key 'car)
unless (zerop ct)
do (trc "pop" ct type))))
#+test
(md-census-report)
#+test
(md-census-count)
(defun md-census-count (&optional type)
(when *model-pop*
(if type
(gethash type *model-pop* 0)
(loop for v being the hash-values of *model-pop*
summing v))))
(defun count-model (self &key count-cells &aux (ccc 0))
(setf *c-d-d* (make-hash-table :test 'eq) *max-d-d* 0)
(let ((*counted* (make-hash-table :test 'eq :size 5000)))
(with-metrics (t nil "cells statistics for" self)
(labels ((cc (self from)
(unless (gethash self *counted*)
(setf (gethash self *counted*) t)
(typecase self
(cons (cc (car self) from)
(cc (cdr self) from))
#+nahhhh (mathx::box (count-it! :mathx-box-struct)
(cc (mathx::bx-mx self) from))
(model
(when (zerop (mod (incf ccc) 100))
(trc "cc" (md-name self) (type-of self)))
(count-it! :thing)
(count-it! :thing (type-of self))
#+nahhhh (when (typep self 'mathx::problem)
(count-it! :thing-from (type-of self) (type-of from)))
(when count-cells
(loop for (nil . c) in (cells self)
do (count-it! :live-cell)
;(count-it! :live-cell id)
(when (c-lazy c)
(count-it! :lazy)
(count-it! :lazy (c-value-state c)))
(typecase c
(c-dependent
(count-it! :dependent-cell)
#+chill (loop repeat (length (c-useds c))
do (count-it! :cell-useds)
(count-it! :dep-depth (c-depend-depth c))))
(otherwise (if (c-inputp c)
(progn
(count-it! :c-input-altogether)
;(count-it! :c-input id)
)
(count-it! :c-unknown))))
(loop repeat (length (c-callers c))
do (count-it! :cell-callers)))
(loop repeat (length (cells-flushed self))
do (count-it! :flushed-cell #+toomuchinfo id)))
(loop for slot in (md-owning-slots self) do
(loop for k in (let ((sv (slot-value self slot)))
(if (listp sv) sv (list sv)))
do (cc k self)))
#+nahhh
(progn
(when (typep self 'mathx::mx-optr)
(cc (mathx::opnds self) from))
(when (typep self 'mathx::math-expression)
(count-it! :math-expression))))
(otherwise
(count-it (type-of self)))))))
(cc self nil)))))
(defun c-depend-depth (ctop)
(if (null (c-useds ctop))
0
(or (gethash ctop *c-d-d*)
(labels ((cdd (c &optional (depth 1) chain)
(when (and (not (c-useds c))
(> depth *max-d-d*))
(setf *max-d-d* depth)
(trc "new dd champ from user" depth :down-to c)
(when (= depth 41)
(trc "end at" (c-slot-name c) :of (type-of (c-model c)))
(loop for c in chain do
(trc "called by" (c-slot-name c) :of (type-of (c-model c))))))
(setf (gethash c *c-d-d*)
;(break "c-depend-depth ~a" c)
(progn
;(trc "dd" c)
(1+ (loop for u in (c-useds c)
maximizing (cdd u (1+ depth) (cons c chain))))))))
(cdd ctop)))))