Commit cff15c11 authored by Kenny Tilton's avatar Kenny Tilton
Browse files

Mostly differentiating new *depender* from CAR of *call-stack* so we can clear...

Mostly differentiating new *depender* from CAR of *call-stack* so we can clear former to get without-c-dependency behavior without clearing *call-stack*, in turn to detect cyclic calculation even if doing a without-c-dependency.
parent 07a72a28
......@@ -43,7 +43,7 @@ It might look something like this:
(defobserver enabled ((self menu-item) new-value old-value old-value-bound?)
(menu-item-set (c-ptr self) (if new-value 1 0)))
ie, Somr model attributes must be propagated outside the model as they change, and observers
ie, Some model attributes must be propagated outside the model as they change, and observers
are callbacks we can provide to handle change.
Motivation
......
......@@ -78,6 +78,11 @@ See the Lisp Lesser GNU Public License for more details.
`(c-break "failed assertion: ~a" ',assertion)))))
(defvar *call-stack* nil)
(defvar *depender* nil)
;; 2008-03-15: *depender* let's us differentiate between the call stack and
;; and dependency. The problem with overloading *call-stack* with both roles
;; is that we miss cyclic reentrance when we use without-c-dependency in a
;; rule to get "once" behavior or just when fm-traversing to find someone
(defmacro def-c-trace (model-type &optional slot cell-type)
`(defmethod trcp ((self ,(case cell-type
......@@ -92,7 +97,7 @@ See the Lisp Lesser GNU Public License for more details.
`(call-without-c-dependency (lambda () ,@body)))
(defun call-without-c-dependency (fn)
(let (*call-stack*)
(let (*depender*)
(funcall fn)))
(export! .cause)
......
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
;;;
;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
;;; Copyright (c) 2008 by Kenneth William Tilton.
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
......
......@@ -39,13 +39,13 @@ See the Lisp Lesser GNU Public License for more details.
(ephemeral-reset c)))
(defmethod awaken-cell ((c c-ruled))
(let (*call-stack*)
(let (*depender*)
(calculate-and-set c)))
#+cormanlisp ; satisfy CormanCL bug
(defmethod awaken-cell ((c c-dependent))
(let (*call-stack*)
(trc nil "awaken-cell c-dependent clearing *call-stack*" c)
(let (*depender*)
(trc nil "awaken-cell c-dependent clearing *depender*" c)
(calculate-and-set c)))
(defmethod awaken-cell ((c c-drifter))
......
......@@ -18,17 +18,17 @@ See the Lisp Lesser GNU Public License for more details.
(in-package :cells)
(defun record-caller (used &aux (caller (car *call-stack*)))
(defun record-caller (used)
(when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell
(trc nil "caller not being recorded because used optimized away" caller (c-value used) :used used)
(trc nil "depender not being recorded because used optimized away" *depender* (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)))
(trc nil "record-caller entry: used=" used :caller *depender*)
#+cool (when (and (eq :ccheck (md-name (c-model *depender*)))
(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)
for known in (cd-useds *depender*)
counting known into length
when (eq used known)
do
......@@ -37,20 +37,20 @@ See the Lisp Lesser GNU Public License for more details.
finally (return (values (when u-pos (- length u-pos)) length)))
(when (null used-pos)
(trc nil "c-link > new caller,used " caller used)
(trc nil "c-link > new caller,used " *depender* used)
(count-it :new-used)
(setf used-pos useds-len)
(push used (cd-useds caller))
(caller-ensure used caller) ;; 060604 experiment was in unlink
(push used (cd-useds *depender*))
(caller-ensure used *depender*) ;; 060604 experiment was in unlink
)
(handler-case
(setf (sbit (cd-usage caller) used-pos) 1)
(setf (sbit (cd-usage *depender*) used-pos) 1)
(type-error (error)
(declare (ignorable error))
(setf (cd-usage caller)
(adjust-array (cd-usage caller) (+ used-pos 16) :initial-element 0))
(setf (sbit (cd-usage caller) used-pos) 1))))
(setf (cd-usage *depender*)
(adjust-array (cd-usage *depender*) (+ used-pos 16) :initial-element 0))
(setf (sbit (cd-usage *depender*) used-pos) 1))))
used)
......
......@@ -53,7 +53,7 @@ See the Lisp Lesser GNU Public License for more details.
(prog1
(with-integrity ()
(ensure-value-is-current c :c-read nil))
(when (car *call-stack*)
(when *depender*
(record-caller c))))
(defun chk (s &optional (key 'anon))
......@@ -131,7 +131,7 @@ See the Lisp Lesser GNU Public License for more details.
(bwhen (v (c-value c))
(if (mdead v)
(progn
(brk "on pulse ~a ensure-value still got and still not returning ~a dead value ~a" *data-pulse-id* c v)
(format t "~&on pulse ~a ensure-value still got and still not returning ~a dead value ~a" *data-pulse-id* c v)
nil)
v)))
......@@ -178,6 +178,7 @@ See the Lisp Lesser GNU Public License for more details.
(defun calculate-and-link (c)
(let ((*call-stack* (cons c *call-stack*))
(*depender* c)
(*defer-changes* t))
(assert (typep c 'c-ruled))
#+shhh (trc c "calculate-and-link" c)
......
......@@ -76,10 +76,10 @@ See the Lisp Lesser GNU Public License for more details.
(when prior-value
(assert prior-value-supplied () "How can prior-value-supplied be nil if prior-value is not?!! ~a" c))
(let (*call-stack*
(let (*depender* *call-stack* ;; I think both need clearing, cuz we are neither depending nor calling when we prop to callers
(*c-prop-depth* (1+ *c-prop-depth*))
(*defer-changes* t))
(trc nil "c.propagate clearing *call-stack*" c)
(trc nil "c.propagate clearing *depender*" c)
;------ debug stuff ---------
;
......@@ -122,7 +122,7 @@ See the Lisp Lesser GNU Public License for more details.
; expected to have side-effects, so we want to propagate fully and be sure no rule
; wants a rollback before starting with the side effects.
;
(unless nil #+not (member (c-lazy c) '(t :always :once-asked)) ;; 2006-09-26 still fuzzy on this
(progn ;; unless (member (c-lazy c) '(t :always :once-asked)) ;; 2006-09-26 still fuzzy on this
(c-propagate-to-callers c))
(trc nil "c.propagate observing" c)
......@@ -218,6 +218,7 @@ See the Lisp Lesser GNU Public License for more details.
#+slow (TRC c "c.propagate-to-callers > queueing notifying callers" (c-callers c))
(with-integrity (:tell-dependents c)
(assert (null *call-stack*))
(assert (null *depender*))
(let ((*causation* causation))
(trc nil "c.propagate-to-callers > actually notifying callers of" c (c-callers c))
#+c-debug (dolist (caller (c-callers c))
......@@ -235,7 +236,20 @@ See the Lisp Lesser GNU Public License for more details.
(assert (find c (cd-useds caller))() "Caller ~a of ~a does not have it as used" caller c)
#+slow (trc c "propagating to caller is used" c :caller caller (c-currentp c))
(let ((*trc-ensure* (trcp c)))
(ensure-value-is-current caller :prop-from c)))))))))
;
; we just c-calculate-and-set? at the first level of dependency because
; we do not need to check the next level (as ensure-value-is-current does)
; because we already know /this/ notifying dependency has changed, so yeah,
; any first-level cell /has to/ recalculate. (As for ensuring other dependents
; of the first level guy are current, that happens automatically anyway JIT on
; any read.) This is a minor efficiency enhancement since ensure-value-is-current would
; very quickly decide it has to re-run, but maybe it makes the logic clearer.
;
;(ensure-value-is-current caller :prop-from c) <-- next was this, but see above change reason
;
(unless (c-currentp caller) ; happens if I changed when caller used me in current pulse
(calculate-and-set caller))
))))))))
(defparameter *the-unpropagated* nil)
......
......@@ -22,14 +22,13 @@ See the Lisp Lesser GNU Public License for more details.
(export '(mk-synapse f-delta f-sensitivity f-plusp f-zerop fdifferent with-synapse)))
(defmacro with-synapse (synapse-id (&rest closure-vars) &body body)
(let ((syn-id (gensym))(syn-caller (gensym)))
(let ((syn-id (gensym)))
`(let* ((,syn-id ,synapse-id)
(,syn-caller (car *call-stack*))
(synapse (or (find ,syn-id (cd-useds ,syn-caller) :key 'c-slot-name)
(synapse (or (find ,syn-id (cd-useds *depender*) :key 'c-slot-name)
(let ((new-syn
(let (,@closure-vars)
(make-c-dependent
:model (c-model ,syn-caller)
:model (c-model *depender*)
:slot-name ,syn-id
:code ',body
:synaptic t
......@@ -39,7 +38,7 @@ See the Lisp Lesser GNU Public License for more details.
(prog1
(multiple-value-bind (v p)
(with-integrity ()
(ensure-value-is-current synapse :synapse (car *call-stack*)))
(ensure-value-is-current synapse :synapse *depender*))
(values v p))
(record-caller synapse)))))
......
......@@ -76,7 +76,7 @@ See the Lisp Lesser GNU Public License for more details.
*trcdepth*)
(format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*)
(format stream "~&"))
(format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10))
;;(format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10))
(setf *last-trc* (get-internal-real-time))
(format stream "~a" s)
(let (pkwp)
......
......@@ -56,7 +56,7 @@ See the Lisp Lesser GNU Public License for more details.
(defmacro count-it (&rest keys)
(declare (ignorable keys))
#+(or) `(progn)
`(when *counting*
`(when (car *counting*)
(call-count-it ,@keys)))
(defun call-count-it (&rest keys)
......
......@@ -188,21 +188,11 @@ See the Lisp Lesser GNU Public License for more details.
(char= #\; (schar trim 0)))))
count 1)))
#+save
(defun source-line-count (path)
(with-open-file (s path)
(loop with lines = 0
for c = (read-char s nil nil)
while c
when (find c '(#\newline #\return))
do (incf lines)
finally (return lines))))
#+(or)
(line-count (make-pathname
:device "c"
:directory `(:absolute "0Algebra" "Cells"))
nil 1 t)
:directory `(:absolute "ALGCOUNT" ))
nil 5 t)
#+(or)
(loop for d1 in '("cl-s3" "kpax" "puri-1.5.1" "s-base64" "s-http-client" "s-http-server" "s-sysdeps" "s-utils" "s-xml")
......
......@@ -113,6 +113,11 @@ See the Lisp Lesser GNU Public License for more details.
`(let ((,bindvar ,boundform))
(when ,bindvar
,@body)))
(defmacro b-when (bindvar boundform &body body)
`(let ((,bindvar ,boundform))
(when ,bindvar
,@body)))
(defmacro bif ((bindvar boundform) yup &optional nope)
`(let ((,bindvar ,boundform))
......@@ -120,11 +125,17 @@ See the Lisp Lesser GNU Public License for more details.
,yup
,nope)))
(defmacro b-if (bindvar boundform yup &optional nope)
`(let ((,bindvar ,boundform))
(if ,bindvar
,yup
,nope)))
(defmacro maptimes ((nvar count) &body body)
`(loop for ,nvar below ,count
collecting (progn ,@body)))
(export! maphash* hashtable-assoc -1?1 -1?1 prime?)
(export! maphash* hashtable-assoc -1?1 -1?1 prime? b-if b-when)
(defun maphash* (f h)
(loop for k being the hash-keys of h
......@@ -195,7 +206,7 @@ See the Lisp Lesser GNU Public License for more details.
(defun without-repeating-generator (decent-interval all)
(let ((len (length all))
(head (let ((v (copy-list all)))
(head (let ((v (shuffle all)))
(nconc v v))))
(lambda ()
(if (< len 2)
......@@ -207,7 +218,16 @@ See the Lisp Lesser GNU Public License for more details.
(car head)
(setf head (cdr head)))))))
(export! without-repeating)
(defun shuffle (list &key (test 'identity))
(if (cdr list)
(loop thereis
(funcall test
(mapcar 'cdr
(sort (loop for e in list collecting (cons (random most-positive-fixnum) e))
'< :key 'car))))
(copy-list list)))
(export! without-repeating shuffle)
(let ((generators (make-hash-table :test 'equalp)))
(defun reset-without-repeating ()
......
......@@ -86,41 +86,114 @@ Act from faith, and failure makes you blame someone and push harder.
|#
(in-package :cells)
(in-package :ukt)
;;;(defstruct (juad jar jbr jcr jdr)
(defun qar (q) (car q))
(defun (setf qar) (v q) (setf (car q) v))
(defun qbr (q) (cadr q))
(defun (setf qbr) (v q) (setf (cadr q) v))
(defun qcr (q) (caddr q))
(defun (setf qcr) (v q) (setf (caddr q) v))
(defun qdr (q) (cdddr q))
(defun (setf qdr) (v q) (setf (cdddr q) v))
(defun sub-quads (q)
(loop for childq on (qcr q) by #'qdr
collecting childq))
(defun sub-quads-do (q fn)
(loop for childq on (qcr q) by #'qdr
do (funcall fn childq)))
(defun quad-traverse (q fn &optional (depth 0))
(funcall fn q depth)
(loop for childq on (qcr q) by #'qdr
do (quad-traverse childq fn (1+ depth))))
(sub-quads-do q
(lambda (subq)
(quad-traverse subq fn (1+ depth)))))
(defun quad (operator parent contents next)
(list operator parent contents next))
(defun quad* (operator parent contents next)
(list operator parent contents next))
(defun qups (q)
(loop for up = (qbr q) then (qbr up)
unless up do (loop-finish)
collecting up))
(defun quad-tree (q)
(list* (qar q)
(loop for childq on (qcr q) by #'qdr
while childq
collecting (quad-tree childq))))
(defun tree-quad (tree &optional parent)
(let* ((q (quad (car tree) parent nil nil))
(kids (loop for k in (cdr tree)
collecting (tree-quad k q))))
(loop for (k n) on kids
do (setf (qdr k) n))
(setf (qcr q) (car kids))
q))
#+test
(test-qt)
(defun test-qt ()
(print (quad-tree #1='(zot nil (foo #1# ("123" "abc")
. #2=(bar #1# (ding #2# "456"
dong #2# "789")))))))
(print #1='(zot nil (foo #1# ("123" "abc")
. #2=(bar #1# (ding #2# "456"
dong #2# "789")))))
#+xxxx
(test-tq)
(defun test-tq ()
(let ((*print-circle* t)
(tree '(zot (foo ("123")) (bar (ding) (dong)))))
(assert (equal tree (quad-tree (tree-quad tree))))))
(defun testq ()
(let ((*print-circle* t))
(let ((q #1='(zot nil (foo #1# "123"
(let ((q #1='(zot nil (foo #1# ("123" "abc")
. #2=(bar #1# (ding #2# "456"
dong #2# "789"))))))
(print '(traverse showing each type and data preceded by its depth))
(quad-traverse q (lambda (q depth)
(print (list depth (qar q))))))
(print (list depth (qar q)(qcr q)))))
(print `(listify same ,(quad-tree q))))
(let ((q #2='(zot nil (ding #2# "456"
dong #2# "789"))))
(print '(traverse showing each "car" and itd parentage preceded by its depth))
(print '(of data (zot (ding (dong)))))
(quad-traverse q (lambda (q depth)
(print (list depth (qar q)
(mapcar 'qar (qups q)))))))))
;;;(defun tree-quad (tree)
(defun testq2 ()
(let ((*print-circle* t))
(let ((q #2='(zot nil (ding #2# "456"
dong #2# "789"))))
(print '(traverse showing each "car" and itd parentage preceded by its depth))
(print '(of data (zot (ding (dong)))))
(quad-traverse q (lambda (q depth)
(print (list depth (qar q)
(mapcar 'qar (qups q)))))))))
\ No newline at end of file
;; -*- lisp-version: "8.1 [Windows] (Sep 29, 2007 20:23)"; cg: "1.103.2.10"; -*-
;; -*- lisp-version: "8.1 [Windows] (Feb 1, 2008 18:35)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
......
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