Update of /project/cells/cvsroot/cells In directory common-lisp.net:/tmp/cvs-serv15391 Modified Files: cell-types.lisp cells.lpr link.lisp md-slot-value.lisp propagate.lisp synapse-types.lisp synapse.lisp test.lisp Log Message: Fix synapses, unifying with ruled cells Date: Thu May 19 22:17:47 2005 Author: ktilton Index: cells/cell-types.lisp diff -u cells/cell-types.lisp:1.3 cells/cell-types.lisp:1.4 --- cells/cell-types.lisp:1.3 Wed May 18 23:47:29 2005 +++ cells/cell-types.lisp Thu May 19 22:17:47 2005 @@ -95,20 +95,20 @@ :stepper ,stepper :to ,to :donep ,donep)))) -(defmethod md-slot-value-assume :around ((c c-stream) (s streamer)) - (bif (to (streamer-to s)) - (loop for slot-value = (streamer-from s) - then (bif (stepper (streamer-stepper s)) - (funcall stepper c) - (incf slot-value)) - until (bif (to (streamer-to s)) - (> slot-value to) - (bwhen (donep-test (streamer-donep s)) - (funcall donep-test c))) - do (progn - (print `(assume doing ,slot-value)) - (call-next-method c slot-value)))) - (c-optimize-away?! c)) +;;;(defmethod md-slot-value-assume :around ((c c-stream) (s streamer)) +;;; (bif (to (streamer-to s)) +;;; (loop for slot-value = (streamer-from s) +;;; then (bif (stepper (streamer-stepper s)) +;;; (funcall stepper c) +;;; (incf slot-value)) +;;; until (bif (to (streamer-to s)) +;;; (> slot-value to) +;;; (bwhen (donep-test (streamer-donep s)) +;;; (funcall donep-test c))) +;;; do (progn +;;; (print `(assume doing ,slot-value)) +;;; (call-next-method c slot-value)))) +;;; (c-optimize-away?! c)) #+test (progn Index: cells/cells.lpr diff -u cells/cells.lpr:1.2 cells/cells.lpr:1.3 --- cells/cells.lpr:1.2 Sun May 8 01:12:40 2005 +++ cells/cells.lpr Thu May 19 22:17:47 2005 @@ -24,7 +24,10 @@ (make-instance 'module :name "family.lisp") (make-instance 'module :name "fm-utilities.lisp") (make-instance 'module :name "family-values.lisp") - (make-instance 'module :name "test.lisp")) + (make-instance 'module :name "test.lisp") + (make-instance 'module :name "test-ephemeral.lisp") + (make-instance 'module :name "test-cycle.lisp") + (make-instance 'module :name "test-synapse.lisp")) :projects (list (make-instance 'project-module :name "utils-kt\\utils-kt")) :libraries nil Index: cells/link.lisp diff -u cells/link.lisp:1.2 cells/link.lisp:1.3 --- cells/link.lisp:1.2 Wed May 18 23:47:29 2005 +++ cells/link.lisp Thu May 19 22:17:47 2005 @@ -140,7 +140,7 @@ ;---------------------------------------------------------- (defun c-unlink-user (used user) - #+dfdbg (trc user "user unlinking from used" user used) + (trc nil "user unlinking from used" user used) (setf (c-users used) (delete user (c-users used))) (c-unlink-used user used)) Index: cells/md-slot-value.lisp diff -u cells/md-slot-value.lisp:1.5 cells/md-slot-value.lisp:1.6 --- cells/md-slot-value.lisp:1.5 Wed May 18 23:47:29 2005 +++ cells/md-slot-value.lisp Thu May 19 22:17:47 2005 @@ -96,19 +96,18 @@ (cd-usage-clear-all c) - (let ((raw-value - (progn - (let ((*c-calculators* (cons c *c-calculators*))) - (trc nil "c-calculate-and-set> new *c-calculators*:" - *c-calculators*) - (c-assert (c-model c)) - (funcall (cr-rule c) c))))) + (multiple-value-bind (raw-value propagation-code) + (let ((*c-calculators* (cons c *c-calculators*))) + (trc nil "c-calculate-and-set> new *c-calculators*:" + *c-calculators*) + (c-assert (c-model c)) + (funcall (cr-rule c) c)) (when (and *c-debug* (typep raw-value 'cell)) (c-break "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))" c raw-value)) (c-unlink-unused c) - (md-slot-value-assume c raw-value)))) + (md-slot-value-assume c raw-value propagation-code)))) (if nil ;; *dbg* (ukt::wtrc (0 100 "calcnset" c) (body))(body)))) @@ -155,13 +154,13 @@ (with-integrity (:setf :setf c new-value) (trc nil "(setf md-slot-value) calling assume" c new-value) - (md-slot-value-assume c new-value)) + (md-slot-value-assume c new-value nil)) new-value) -(defmethod md-slot-value-assume (c raw-value) +(defmethod md-slot-value-assume (c raw-value propagation-code) (assert c) (without-c-dependency (let ((prior-state (c-value-state c)) @@ -179,15 +178,17 @@ (c-value-state c) :valid (c-state c) :awake) - (unless (typep c 'c-stream) ;; c-stream needs to run out first stream at least - (c-optimize-away?! c)) ;;; put optimize test here to avoid needless linking +;;; (unless (typep c 'c-stream) ;; c-stream needs to run out first stream at least +;;; (c-optimize-away?! c)) ;;; put optimize test here to avoid needless linking ; --- data flow propagation ----------- ; (trc nil "md-sv comparing" c prior-state absorbed-value prior-value) - (if (and (eql prior-state :valid) - (c-no-news c absorbed-value prior-value)) + (if (or (eq propagation-code :no-propagate) + (and (null propagation-code) + (eql prior-state :valid) + (c-no-news c absorbed-value prior-value))) (progn (trc nil "(setf md-slot-value) >no news" prior-state (c-no-news c absorbed-value prior-value)) (count-it :nonews)) Index: cells/propagate.lisp diff -u cells/propagate.lisp:1.4 cells/propagate.lisp:1.5 --- cells/propagate.lisp:1.4 Wed May 18 23:47:29 2005 +++ cells/propagate.lisp Thu May 19 22:17:47 2005 @@ -42,7 +42,7 @@ (when *stop* (princ #\.)(princ #\!) (return-from c-propagate)) - (trc nil "c-propagate> propping" c (c-value c) (length (c-users c)) c) + (trc nil "c-propagate> propping" c (c-value c) :user-ct (length (c-users c)) c) (when *c-debug* (when (> *c-prop-depth* 250) Index: cells/synapse-types.lisp diff -u cells/synapse-types.lisp:1.1 cells/synapse-types.lisp:1.2 --- cells/synapse-types.lisp:1.1 Fri May 6 23:05:45 2005 +++ cells/synapse-types.lisp Thu May 19 22:17:47 2005 @@ -22,50 +22,72 @@ (in-package :cells) -(defmacro f-sensitivity ((sensitivity &optional subtypename) &body body) - `(with-synapse ((prior-fire-value) - :fire-p (lambda (syn new-value) - (declare (ignorable syn)) - (trc nil "f-sensitivity fire-p decides" prior-fire-value ,sensitivity) - (or (xor prior-fire-value new-value) - (eko (nil "fire-p decides" new-value prior-fire-value ,sensitivity) +(defmacro f-sensitivity (synapse-id (sensitivity &optional subtypename) &body body) + `(call-f-sensitivity ,synapse-id ,sensitivity ,subtypename (lambda () ,@body))) + +(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) + (let ((prop-code (if (or (xor prior-fire-value new-value) + (eko ("sens fire-p decides" new-value prior-fire-value sensitivity) (delta-greater-or-equal - (delta-abs (delta-diff new-value prior-fire-value ,subtypename) - ,subtypename) - (delta-abs ,sensitivity ,subtypename) - ,subtypename)))) - - :fire-value (lambda (syn new-value) - (declare (ignorable syn)) - (eko (nil "fsensitivity relays") - (setf prior-fire-value new-value)))) - ,@body)) - -(defmacro f-delta ((&key sensitivity (type 'number)) &body body) - (let ((threshold (gensym)) (tdelta (gensym))) - `(with-synapse ((last-relay-basis last-bound-p delta-cum) - :fire-p (lambda (syn new-basis) - (declare (ignorable syn)) - (let ((,threshold ,sensitivity) - (,tdelta (delta-diff new-basis - (if last-bound-p - last-relay-basis - (delta-identity new-basis ',type)) - ',type))) - (trc "tdelta, threshhold" ,tdelta ,threshold) - (setf delta-cum ,tdelta) - (eko ("delta fire-p") - (or (null ,threshold) - (delta-exceeds ,tdelta ,threshold ',type))))) - - :fire-value (lambda (syn new-basis) - (declare (ignorable syn)) - (trc "f-delta fire-value gets" delta-cum new-basis syn) - (trc "fdelta > new lastrelay" syn last-relay-basis) - (setf last-bound-p t) - (setf last-relay-basis new-basis) - delta-cum)) - ,@body))) + (delta-abs (delta-diff new-value prior-fire-value subtypename) + subtypename) + (delta-abs sensitivity subtypename) + subtypename))) + :propagate + :no-propagate))) + (values (if (eq prop-code :propagate) + (progn + (trc "sense prior fire value now" new-value) + (setf prior-fire-value new-value)) + new-value) prop-code))))) + +(defmacro f-delta (synapse-id (&key sensitivity (type 'number)) &body body) + `(call-f-delta ,synapse-id ,sensitivity ',type (lambda () ,@body))) + +(defun call-f-delta (synapse-id sensitivity type body-fn) + (with-synapse synapse-id (last-relay-basis last-bound-p delta-cum) + (let* ((new-basis (funcall body-fn)) + (threshold sensitivity) + (tdelta (delta-diff new-basis + (if last-bound-p + last-relay-basis + (delta-identity new-basis type)) + type))) + (trc nil "tdelta, threshhold" tdelta threshold) + (setf delta-cum tdelta) + (let ((propagation-code + (when threshold + (if (delta-exceeds tdelta threshold type) + (progn + (setf last-bound-p t) + (setf last-relay-basis new-basis) + :propagate) + :no-propagate)))) + (trc nil "f-delta returns values" delta-cum propagation-code) + (values delta-cum propagation-code))))) + +(defmacro f-plusp (key &rest body) + `(with-synapse ,key (prior-fire-value) + (let ((new-basis (progn ,@body))) + (values new-basis (if (xor prior-fire-value (plusp new-basis)) + (progn + (setf prior-fire-value (plusp new-basis)) + :propagate) + :no-propagate))))) + +(defmacro f-zerop (key &rest body) + `(with-synapse ,key (prior-fire-value) + (let ((new-basis (progn ,@body))) + (values new-basis (if (xor prior-fire-value (zerop new-basis)) + (progn + (setf prior-fire-value (zerop new-basis)) + :propagate) + :no-propagate))))) + + ;;;(defun f-delta-list (&key (test #'true)) ;;; (with-synapse (prior-list) @@ -101,32 +123,6 @@ ;;; (and (not bingobound) ;; don't bother if fire? already looked ;;; (find-if finder-fn new-list)))))) -;;;(defun f-plusp () -;;; (mk-synapse (prior-fire-value) -;;; :fire-p (lambda (syn new-basis) -;;; (declare (ignorable syn)) -;;; (eko (nil "fPlusp fire-p decides" prior-fire-value sensitivity) -;;; (xor prior-fire-value (plusp new-basis)))) -;;; -;;; :fire-value (lambda (syn new-basis) -;;; (declare (ignorable syn)) -;;; (eko (nil "fPlusp relays") -;;; (setf prior-fire-value (plusp new-basis))) ;; no modulation of value, but do record for next time -;;; ))) - -;;;(defun f-zerop () -;;; (mk-synapse (prior-fire-value) -;;; :fire-p (lambda (syn new-basis) -;;; (declare (ignorable syn)) -;;; (eko (nil "fZerop fire-p decides") -;;; (xor prior-fire-value (zerop new-basis)))) -;;; -;;; :fire-value (lambda (syn new-basis) -;;; (declare (ignorable syn)) -;;; (eko (nil "fZerop relays") -;;; (setf prior-fire-value (zerop new-basis))) -;;; ))) - ;;;(defun fdifferent () ;;; (mk-synapse (prior-object) ;;; :fire-p (lambda (syn new-object) Index: cells/synapse.lisp diff -u cells/synapse.lisp:1.3 cells/synapse.lisp:1.4 --- cells/synapse.lisp:1.3 Wed May 18 23:47:29 2005 +++ cells/synapse.lisp Thu May 19 22:17:47 2005 @@ -25,41 +25,31 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (export '(mk-synapse f-delta f-sensitivity f-plusp f-zerop fdifferent))) -(defmacro with-synapse (((&rest closure-vars) &key trcp fire-p fire-value) &body body) +(defmacro with-synapse (synapse-id (&rest closure-vars) &body body) (declare (ignorable trcp)) - (let ((lex-loc-key (gensym "synapse-id"))) - `(let ((synapse (or (cdr (assoc ',lex-loc-key - (cd-useds (car *c-calculators*)))) - (cdar (push (cons ',lex-loc-key - (let (,@closure-vars) - (make-synaptic-ruled slot-c (,fire-p ,fire-value) - ,@body))) - (cd-useds - (car *c-calculators*))))))) - (prog1 - (with-integrity (:with-synapse) - (c-value-ensure-current synapse)) - (when (car *c-calculators*) - (c-link-ex synapse)))))) + `(let* ((synapse-user (car *c-calculators*)) + (synapse (or (bIf (ku (find ,synapse-id (cd-useds synapse-user) :key 'c-slot-name)) + (progn + (trc "withsyn reusing known" ,synapse-id ku) + ku)) + (let ((new-syn + (let (,@closure-vars) + (trc "withsyn making new syn" ,synapse-id) + (make-synaptic-ruled ,synapse-id synapse-user ,@body)))) + (c-link-ex new-syn) + new-syn)))) + (prog1 + (with-integrity (:with-synapse) + (c-value-ensure-current synapse)) + (c-link-ex synapse)))) -(defmacro make-synaptic-ruled (syn-user (fire-p fire-value) &body body) - (let ((new-value (gensym)) - (c-var (gensym))) - `(make-c-dependent - :model (c-model ,syn-user) - :slot-name (intern (conc$ "syn-" (string (c-slot-name ,syn-user)))) - :code ',body - :synaptic t - :rule (c-lambda-var (,c-var) - (let ((,new-value (progn ,@body))) - (trc "generic synaptic rule sees body value" ,c-var ,new-value) - (if ,(if fire-p `(funcall ,fire-p ,c-var ,new-value) t) - (progn - (trc "Synapse fire YES!!" ,c-var) - (funcall ,fire-value ,c-var ,new-value)) - (progn - (trc "Synapse fire NO!! use cache" .cache) - .cache))))))) +(defmacro make-synaptic-ruled (syn-pseudo-slot syn-user &body body) + `(make-c-dependent + :model (c-model ,syn-user) + :slot-name ',syn-pseudo-slot + :code ',body + :synaptic t + :rule (c-lambda ,@body))) ;__________________________________________________________________________________ ; Index: cells/test.lisp diff -u cells/test.lisp:1.4 cells/test.lisp:1.5 --- cells/test.lisp:1.4 Wed May 18 23:47:29 2005 +++ cells/test.lisp Thu May 19 22:17:47 2005 @@ -63,7 +63,7 @@ (in-package :cells) -(defparameter *cell-tests* nil) +(defvar *cell-tests* nil) #+go @@ -90,7 +90,7 @@ (defmacro ct-assert (form &rest stuff) `(progn (print `(attempting ,',form)) - (assert ,form () "Error stuff ~a" (list ,@stuff)))) + (assert ,form () "Error with ~a >> ~a" ',form (list ,@stuff)))) (defmodel m-null () ((aa :initform nil :cell nil :initarg :aa :accessor aa)))