Commit 9c2a1328 authored by Kenny Tilton's avatar Kenny Tilton
Browse files

*** empty log message ***

parent 5ddb126b
......@@ -66,8 +66,9 @@ See the Lisp Lesser GNU Public License for more details.
(call-next-method)
(progn
(c-print-value c stream)
(format stream "=~d/~a/~a]"
(format stream "=~d/~a/~a/~a]"
(c-pulse c)
(c-state c)
(symbol-name (or (c-slot-name c) :anoncell))
(print-cell-model (c-model c))))))))
......@@ -92,8 +93,6 @@ See the Lisp Lesser GNU Public License for more details.
(defun caller-drop (used caller)
(fifo-delete (c-caller-store used) caller))
; --- ephemerality --------------------------------------------------
;
; Not a type, but an option to the :cell parameter of defmodel
......
......@@ -54,6 +54,7 @@ See the Lisp Lesser GNU Public License for more details.
(defun c-stop (&optional why)
(setf *stop* t)
(print `(c-stop-entry ,why))
(format t "~&C-STOP> stopping because ~a" why) )
(define-symbol-macro .stop
......@@ -151,13 +152,11 @@ See the Lisp Lesser GNU Public License for more details.
(defun c-break (&rest args)
(unless *stop*
(let ((*print-level* 3)
(let ((*print-level* 5)
(*print-circle* t)
)
(args2 (mapcar 'princ-to-string args)))
(c-stop args)
(format t "c-break > stopping > ~a" args)
(apply 'error args))))
(format t "~&c-break > stopping > ~{~a ~}" args2)
(print `(c-break-args ,@args2))
(apply 'error args2))))
\ No newline at end of file
......@@ -33,7 +33,8 @@ See the Lisp Lesser GNU Public License for more details.
(apply #'make-instance part-class (append initargs (list :md-name partname)))))
(defmacro mk-part (md-name (md-class) &rest initargs)
`(make-part ',md-name ',md-class ,@initargs))
`(make-part ',md-name ',md-class ,@initargs
:fm-parent (progn (assert self) self)))
(defmethod make-part-spec ((part-class symbol))
(make-part part-class part-class))
......
......@@ -19,7 +19,8 @@ See the Lisp Lesser GNU Public License for more details.
(:use #:common-lisp #:utils-kt #:cells)
(:export #:geometer #:geo-zero-tl #:geo-inline #:a-stack #:a-row
#:px #:py #:ll #:lt #:lr #:lb #:pl #:pt #:pr #:pb
#:^px #:^py #:^ll #:^lt #:^lr #:^lb
#:^px #:^py #:^ll #:^lt #:^lr #:^lb #:^lb-height
#:^fill-parent-down
#:u96ths #:udots #:uinches #:uin #:upoints #:upts #:u8ths #:u16ths #:u32nds
#:mkr #:v2-nmove #:l-height #:mkv2 #:^offset-within #:inset-lr #:v2-v #:v2-h
#:r-bounds #:l-box
......
......@@ -23,7 +23,9 @@ See the Lisp Lesser GNU Public License for more details.
(trc nil "caller not being recorded because used optimized away" caller (c-value used) :used used)
(return-from record-caller nil))
(trc nil "record-caller entry: used=" used :caller caller)
#+cool (when (and (eq :ccheck (md-name (c-model caller)))
(eq :cview (md-name (c-model used))))
(break "bingo"))
(multiple-value-bind (used-pos useds-len)
(loop with u-pos
for known in (cd-useds caller)
......
......@@ -23,6 +23,8 @@ See the Lisp Lesser GNU Public License for more details.
(defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name)))
(when (mdead self)
(trc "md-slot-value passed dead self, returning NIL" self)
(inspect self)
(break "see inspector for dead ~a" self)
(return-from md-slot-value nil))
(tagbody
retry
......@@ -73,7 +75,7 @@ See the Lisp Lesser GNU Public License for more details.
;
(declare (ignorable debug-id ensurer))
(count-it :ensure-value-is-current)
(trc nil "ensure-value-is-current > entry" c :now-pulse *data-pulse-id* debug-id ensurer)
;; (trc c "ensure-value-is-current > entry" c (c-state c) :now-pulse *data-pulse-id* debug-id ensurer)
(when (and (not (symbolp (c-model c)))(eq :eternal-rest (md-state (c-model c))))
(break "model ~a of cell ~a is dead" (c-model c) c))
......@@ -110,14 +112,15 @@ See the Lisp Lesser GNU Public License for more details.
t))))))
(assert (typep c 'c-dependent))
(check-reversed (cd-useds c))))
#+slow (trc c "kicking off calc-set of" (c-validp c) (c-slot-name c) :vstate (c-value-state c)
#+shhh (trc c "kicking off calc-set of" (c-state c) (c-validp c) (c-slot-name c) :vstate (c-value-state c)
:stamped (c-pulse c) :current-pulse *data-pulse-id*)
(calculate-and-set c))
((mdead (c-value c))
(trc "ensure-value-is-current> trying recalc of ~a with current but dead value ~a" c (c-value c))
(trc nil "ensure-value-is-current> trying recalc of ~a with current but dead value ~a" c (c-value c))
(let ((new-v (calculate-and-set c)))
(trc "ensure-value-is-current> GOT new value ~a" new-v)))
(trc nil "ensure-value-is-current> GOT new value ~a to replace dead!!" new-v)
new-v))
(t (trc nil "ensuring current decided current, updating pulse" (c-slot-name c) debug-id)
(c-pulse-update c :valid-uninfluenced)))
......@@ -128,7 +131,7 @@ See the Lisp Lesser GNU Public License for more details.
(bwhen (v (c-value c))
(if (mdead v)
(progn
(brk "ensure-value still got and still not returning ~a dead value ~a" c v)
(brk "on pulse ~a ensure-value still got and still not returning ~a dead value ~a" *data-pulse-id* c v)
nil)
v)))
......@@ -162,8 +165,14 @@ See the Lisp Lesser GNU Public License for more details.
(c-break "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))"
c raw-value))
(md-slot-value-assume c raw-value propagation-code))))
(if nil ;; *dbg*
(unless (c-optimized-away-p c)
; this check for optimized-away-p arose because a rule using without-c-dependency
; can be re-entered unnoticed since that clears *call-stack*. If re-entered, a subsequent
; re-exit will be of an optimized away cell, which we need not sv-assume on... a better
; fix might be a less cutesy way of doing without-c-dependency, and I think anyway
; it would be good to lose the re-entrance.
(md-slot-value-assume c raw-value propagation-code)))))
(if (trcp c) ;; *dbg*
(wtrc (0 100 "calcnset" c) (body))
(body))))
......@@ -171,7 +180,7 @@ See the Lisp Lesser GNU Public License for more details.
(let ((*call-stack* (cons c *call-stack*))
(*defer-changes* t))
(assert (typep c 'c-ruled))
#+slow (trc *c-debug* "calculate-and-link" c)
#+shhh (trc c "calculate-and-link" c)
(cd-usage-clear-all c)
(multiple-value-prog1
(funcall (cr-rule c) c)
......@@ -236,6 +245,7 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
(md-slot-value-assume c new-value nil))
(*defer-changes*
(print `(cweird ,c ,(type-of c)))
(c-break "SETF of ~a must be deferred by wrapping code in WITH-INTEGRITY" c))
(t
......@@ -250,6 +260,7 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
(defmethod md-slot-value-assume (c raw-value propagation-code)
(assert c)
#+shhh (trc c "md-slot-value-assume entry" (c-state c))
(without-c-dependency
(let ((prior-state (c-value-state c))
(prior-value (c-value c))
......@@ -266,9 +277,12 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
(return-from md-slot-value-assume absorbed-value))
; --- slot maintenance ---
(when (eq (c-state c) :optimized-away)
(break "bongo one ~a flush ~a" c (flushed? c)))
(unless (c-synaptic c)
(md-slot-value-store (c-model c) (c-slot-name c) absorbed-value))
(when (eq (c-state c) :optimized-away)
(break "bongo two ~a flush ~a" c (flushed? c)))
; --- cell maintenance ---
(setf
(c-value c) absorbed-value
......@@ -299,7 +313,11 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
;---------- optimizing away cells whose dependents all turn out to be constant ----------------
;
(defun flushed? (c)
(rassoc c (cells-flushed (c-model c))))
(defun c-optimize-away?! (c)
#+shhh (trc c "c-optimize-away?! entry" (c-state c) c)
(when (and (typep c 'c-dependent)
(null (cd-useds c))
(cd-optimize c)
......@@ -309,21 +327,27 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
(not (c-inputp c)) ;; yes, dependent cells can be inputp
)
;; (when (trcp c) (break "go optimizing ~a" c))
(trc nil "optimizing away" c (c-state c))
#+shh (when (trcp c)
(trc "optimizing away" c (c-state c) (rassoc c (cells (c-model c)))(rassoc c (cells-flushed (c-model c))))
)
(count-it :c-optimized)
(setf (c-state c) :optimized-away)
(let ((entry (rassoc c (cells (c-model c)))))
(unless entry
(describe c))
(describe c)
(bwhen (fe (rassoc c (cells-flushed (c-model c))))
(trc "got in flushed thoi!" fe)))
(c-assert entry)
(trc nil "c-optimize-away?! moving cell to flushed list" c)
;(trc (eq (c-slot-name c) 'cgtk::id) "c-optimize-away?! moving cell to flushed list" c)
(setf (cells (c-model c)) (delete entry (cells (c-model c))))
#-its-alive! (push entry (cells-flushed (c-model c)))
)
(dolist (caller (c-callers c))
(dolist (caller (c-callers c) )
;
; example: on window shutdown with a tool-tip displayed, the tool-tip generator got
; kicked off and asked about the value of a dead instance. That returns nil, and
......@@ -332,6 +356,7 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
; so we ended up here. where there used to be a break.
;
(setf (cd-useds caller) (delete c (cd-useds caller)))
;;; (trc "nested opti" c caller)
(c-optimize-away?! caller) ;; rare but it happens when rule says (or .cache ...)
)))
......
......@@ -40,7 +40,6 @@ See the Lisp Lesser GNU Public License for more details.
nil))
(defgeneric not-to-be (self)
(:method ((self model-object))
(md-quiesce self))
......
......@@ -106,6 +106,9 @@ See the Lisp Lesser GNU Public License for more details.
(when (eql :nascent (md-state self))
(call-next-method)))
#+test
(md-slot-cell-type 'cgtk::label 'cgtk::container)
(defmethod md-awaken ((self model-object))
;
; --- debug stuff
......@@ -123,7 +126,7 @@ See the Lisp Lesser GNU Public License for more details.
(setf (md-state self) :awakening)
(dolist (esd (class-slots (class-of self)))
(when (md-slot-cell-type (type-of self) (slot-definition-name esd))
(bwhen (sct (md-slot-cell-type (type-of self) (slot-definition-name esd)))
(let* ((slot-name (slot-definition-name esd))
(c (md-slot-cell self slot-name)))
(when *c-debug*
......@@ -146,6 +149,7 @@ See the Lisp Lesser GNU Public License for more details.
;; until 2007-10 (unless (cdr (assoc slot-name (cells-flushed self))) ;; make sure not flushed
;; but first I worried about it being slow keeping the flushed list /and/ searching, then
;; I wondered why a flushed cell should not be observed, constant cells are. So Just Observe It
(slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil))
......@@ -175,6 +179,9 @@ See the Lisp Lesser GNU Public License for more details.
(cdr (assoc slot-name (cells self)))
(get slot-name 'cell)))
#+test
(get 'cgtk::label :cell-types)
(defun md-slot-cell-type (class-name slot-name)
(assert class-name)
(if (eq class-name 'null)
......@@ -192,11 +199,11 @@ See the Lisp Lesser GNU Public License for more details.
(setf (get slot-name :cell-type) new-type)
(let ((entry (assoc slot-name (get class-name :cell-types))))
(if entry
(progn
(prog1
(setf (cdr entry) new-type)
(loop for c in (class-direct-subclasses (find-class class-name))
do (setf (md-slot-cell-type (class-name c) slot-name) new-type)))
(push (cons slot-name new-type) (get class-name :cell-types))))))
(cdar (push (cons slot-name new-type) (get class-name :cell-types)))))))
(defun md-slot-owning (class-name slot-name)
(assert class-name)
......
......@@ -36,7 +36,7 @@ See the Lisp Lesser GNU Public License for more details.
(defun call-f-sensitivity (synapse-id sensitivity subtypename body-fn)
(with-synapse synapse-id (prior-fire-value)
(let ((new-value (funcall body-fn)))
(trc nil "f-sensitivity fire-p decides" prior-fire-value sensitivity)
;(trc "f-sensitivity fire-p decides new" new-value :from-prior prior-fire-value :sensi sensitivity)
(let ((prop-code (if (or (xor prior-fire-value new-value)
(eko (nil "sens fire-p decides" new-value prior-fire-value sensitivity)
(delta-greater-or-equal
......
......@@ -33,7 +33,7 @@ See the Lisp Lesser GNU Public License for more details.
`(without-c-dependency
(call-trc t ,tgt-form ,@os))
(let ((tgt (gensym)))
;(break "slowww? ~a" tgt-form)
(break "slowww? ~a" tgt-form)
`(without-c-dependency
(bif (,tgt ,tgt-form)
(if (trcp ,tgt)
......@@ -64,7 +64,7 @@ See the Lisp Lesser GNU Public License for more details.
'(progn)
`(without-c-dependency
(call-trc t ,(format nil "TX> ~(~s~)" tgt-form)
,@(loop for obj in os
,@(loop for obj in (or os (list tgt-form))
nconcing (list (intern (format nil "~a" obj) :keyword) obj))))))
......
......@@ -61,7 +61,8 @@ See the Lisp Lesser GNU Public License for more details.
(defun call-count-it (&rest keys)
(declare (ignorable keys))
;;; (when (eql :TGTNILEVAL (car keys))(break))
(when (find (car keys) '(:trcfailed :TGTNILEVAL))
(break "clean up time ~a" keys))
(let ((entry (assoc keys *count* :test #'equal)))
(if entry
(setf (cdr entry) (1+ (cdr entry)))
......
......@@ -59,24 +59,28 @@ See the Lisp Lesser GNU Public License for more details.
(defun collect-if (test list)
(remove-if-not test list))
#-iamnotkenny
(defun test-setup ()
#-its-alive!
(defun test-setup (&optional drib)
#-(or iamnotkenny its-alive!)
(ide.base::find-new-prompt-command
(cg.base::find-window :listener-frame)))
(cg.base::find-window :listener-frame))
(when drib
(dribble (merge-pathnames
(make-pathname :name drib :type "TXT")
(project-path)))))
(export! project-path)
(defun project-path ()
(excl:path-pathname (ide.base::project-file ide.base:*current-project*)))
#+test
(test-setup)
#-iamnotkenny
(defun test-prep ()
(test-setup))
(defun test-prep (&optional drib)
(test-setup drib))
#-iamnotkenny
(defun test-init ()
(test-setup))
(defun test-init (&optional drib)
(test-setup drib))
#-iamnotkenny
(export! test-setup test-prep test-init)
;;; --- FIFO Queue -----------------------------
......
......@@ -124,6 +124,27 @@ See the Lisp Lesser GNU Public License for more details.
`(loop for ,nvar below ,count
collecting (progn ,@body)))
(export! maphash* hashtable-assoc -1?1 -1?1 prime?)
(defun maphash* (f h)
(loop for k being the hash-keys of h
using (hash-value v)
collecting (funcall f k v)))
(defun hashtable-assoc (h)
(maphash* (lambda (k v) (cons k v)) h))
(define-symbol-macro -1?1 (expt -1 (random 2)))
(defun -1?1 (x) (* -1?1 x))
(defun prime? (n)
(and (> n 1)
(or (= 2 n)(oddp n))
(loop for d upfrom 3 by 2 to (sqrt n)
when (zerop (mod n d)) return nil
finally (return t))))
; --- cloucell support for struct access of slots ------------------------
(eval-when (:compile-toplevel :execute :load-toplevel)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment