cells-cvs

Download

cells-cvs@common-lisp.net

March 2008

4 participants
12 discussions

[cells-cvs] CVS cells
by ktilton 15 Mar '08

15 Mar '08

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv8605 Modified Files: cells-manifesto.txt cells.lisp defpackage.lisp initialize.lisp link.lisp md-slot-value.lisp propagate.lisp synapse.lisp trc-eko.lisp Log Message: 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. --- /project/cells/cvsroot/cells/cells-manifesto.txt 2008/02/16 08:00:59 1.12 +++ /project/cells/cvsroot/cells/cells-manifesto.txt 2008/03/15 15:18:34 1.13 @@ -43,7 +43,7 @@ (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 --- /project/cells/cvsroot/cells/cells.lisp 2008/02/02 00:09:28 1.24 +++ /project/cells/cvsroot/cells/cells.lisp 2008/03/15 15:18:34 1.25 @@ -78,6 +78,11 @@ `(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 @@ `(call-without-c-dependency (lambda () ,@body))) (defun call-without-c-dependency (fn) - (let (*call-stack*) + (let (*depender*) (funcall fn))) (export! .cause) --- /project/cells/cvsroot/cells/defpackage.lisp 2007/11/30 16:51:18 1.10 +++ /project/cells/cvsroot/cells/defpackage.lisp 2008/03/15 15:18:34 1.11 @@ -1,6 +1,6 @@ ;; -*- 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 --- /project/cells/cvsroot/cells/initialize.lisp 2008/02/02 00:09:28 1.10 +++ /project/cells/cvsroot/cells/initialize.lisp 2008/03/15 15:18:34 1.11 @@ -39,13 +39,13 @@ (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)) --- /project/cells/cvsroot/cells/link.lisp 2008/01/29 04:29:52 1.25 +++ /project/cells/cvsroot/cells/link.lisp 2008/03/15 15:18:34 1.26 @@ -18,17 +18,17 @@ (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 @@ 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) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/02/01 03:18:36 1.39 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/03/15 15:18:34 1.40 @@ -53,7 +53,7 @@ (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 @@ (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 @@ (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) --- /project/cells/cvsroot/cells/propagate.lisp 2008/02/02 00:09:28 1.33 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/03/15 15:18:34 1.34 @@ -76,10 +76,10 @@ (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 @@ ; 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 @@ #+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 @@ (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) --- /project/cells/cvsroot/cells/synapse.lisp 2007/11/30 16:51:18 1.15 +++ /project/cells/cvsroot/cells/synapse.lisp 2008/03/15 15:18:34 1.16 @@ -22,14 +22,13 @@ (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 @@ (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))))) --- /project/cells/cvsroot/cells/trc-eko.lisp 2008/01/29 20:42:23 1.9 +++ /project/cells/cvsroot/cells/trc-eko.lisp 2008/03/15 15:18:34 1.10 @@ -76,7 +76,7 @@ *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)

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 15 Mar '08

15 Mar '08

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv8605/utils-kt Modified Files: debug.lisp detritus.lisp flow-control.lisp quad.lisp utils-kt.lpr Log Message: 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. --- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2008/02/16 09:34:29 1.18 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2008/03/15 15:18:34 1.19 @@ -56,7 +56,7 @@ (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) --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/02/16 05:04:56 1.19 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/03/15 15:18:34 1.20 @@ -188,21 +188,11 @@ (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") --- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2008/01/29 04:29:55 1.12 +++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2008/03/15 15:18:34 1.13 @@ -113,6 +113,11 @@ `(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 @@ ,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 @@ (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 @@ (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 () --- /project/cells/cvsroot/cells/utils-kt/quad.lisp 2007/12/03 20:11:12 1.3 +++ /project/cells/cvsroot/cells/utils-kt/quad.lisp 2008/03/15 15:18:34 1.4 @@ -86,41 +86,114 @@ |# -(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 --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2007/11/30 16:51:20 1.23 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2008/03/15 15:18:34 1.24 @@ -1,4 +1,4 @@ -;; -*- 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)

1 0