Commit 8526e5c8 authored by Kenny Tilton's avatar Kenny Tilton
Browse files

Just trying to get a patch in for record-caller

parent 8e725cc5
......@@ -60,7 +60,13 @@ See the Lisp Lesser GNU Public License for more details.
(defmethod print-object ((c cell) stream)
(declare (ignorable stream))
(unless *stop*
(if *stop*
(format stream "<~d:~a ~a/~a = ~a>"
(c-pulse c)
(subseq (string (c-state c)) 0 1)
(symbol-name (or (c-slot-name c) :anoncell))
(md-name (c-model c))
(type-of (c-value c)))
(let ((*print-circle* t))
#+failsafe (format stream "~a/~a" (c-model c)(c-slot-name c))
(if *print-readably*
......@@ -72,7 +78,8 @@ See the Lisp Lesser GNU Public License for more details.
(subseq (string (c-state c)) 0 1)
(symbol-name (or (c-slot-name c) :anoncell))
(print-cell-model (c-model c))
(c-value c)))))))
(if (consp (c-value c))
"LST" (c-value c))))))))
(export! print-cell-model)
......@@ -80,8 +87,9 @@ See the Lisp Lesser GNU Public License for more details.
(:method (other) (print-object other nil)))
(defmethod trcp :around ((c cell))
(or (c-debug c)
(call-next-method)))
(and ;*c-debug*
(or (c-debug c)
(call-next-method))))
(defun c-callers (c)
"Make it easier to change implementation"
......@@ -107,7 +115,7 @@ See the Lisp Lesser GNU Public License for more details.
;
; as of Cells3 we defer resetting ephemerals because everything
; else gets deferred and we cannot /really/ reset it until
; within finish-business we are sure all callers have been recalculated
; within finish_business we are sure all callers have been recalculated
; and all outputs completed.
;
; ;; good q: what does (setf <ephem> 'x) return? historically nil, but...?
......
......@@ -9,21 +9,18 @@
:long-description "Informatively-commented regression tests for Cells"
:serial t
:depends-on (:cells)
:components ((:module "cells-test"
:serial t
:components ((:file "test")
(:file "hello-world")
(:file "test-kid-slotting")
(:file "test-lazy")
(:file "person")
(:file "df-interference")
(:file "test-family")
(:file "output-setf")
(:file "test-cycle")
(:file "test-ephemeral")
(:file "test-synapse")
(:file "deep-cells")))))
:components ((:file "test")
(:file "hello-world")
(:file "test-kid-slotting")
(:file "test-lazy")
(:file "person")
(:file "df-interference")
(:file "test-family")
(:file "output-setf")
(:file "test-cycle")
(:file "test-ephemeral")
(:file "test-synapse")
(:file "deep-cells")))
(defmethod perform :after ((op load-op) (system (eql (find-system :cells-test))))
(funcall (find-symbol "TEST-CELLS" "CELLS")))
;; -*- lisp-version: "8.1 [Windows] (Apr 3, 2008 23:47)"; cg: "1.103.2.10"; -*-
;; -*- lisp-version: "8.1 [Windows] (Oct 11, 2008 17:00)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
......@@ -16,8 +16,11 @@
(make-instance 'module :name "test-cycle.lisp")
(make-instance 'module :name "test-ephemeral.lisp")
(make-instance 'module :name "test-synapse.lisp")
(make-instance 'module :name "deep-cells.lisp"))
:projects (list (make-instance 'project-module :name "..\\cells"))
(make-instance 'module :name "deep-cells.lisp")
(make-instance 'module :name "clos-training.lisp")
(make-instance 'module :name "do-req.lisp"))
:projects (list (make-instance 'project-module :name "..\\cells"
:show-modules nil))
:libraries nil
:distributed-files nil
:internally-loaded-files nil
......@@ -94,6 +97,7 @@
:old-space-size 256000
:new-space-size 6144
:runtime-build-option :standard
:build-number 0
:on-initialization 'cells::test-cells
:on-restart 'do-default-restart)
......
......@@ -4,9 +4,9 @@
(defvar *obs-1-count*)
(defmodel deep ()
((cell-2 :cell :ephemeral :initform (c-in 'two) :accessor :cell-2)
(cell-1 :initform (c? (list 'one (^cell-2) (^cell-3))) :accessor :cell-1)
(cell-3 :initform (c-in 'c3-unset) :accessor :cell-3)))
((cell-2 :cell :ephemeral :initform (c-in 'two) :accessor cell-2)
(cell-1 :initform (c? (list 'one (^cell-2) (^cell-3))) :accessor cell-1)
(cell-3 :initform (c-in 'c3-unset) :accessor cell-3)))
(defobserver cell-1 ()
(trc "cell-1 observer raw now enqueing client to run first. (new,old)=" new-value old-value)
......
......@@ -36,6 +36,16 @@
(incf *name-ct-calc*)
(length (names self))))))
#+test
(progn
(cells-reset)
(inspect
(make-instance 'person
:names '("speedy" "chill")
:pulse (c-in 60)
:speech (c? (car (names self)))
:thought (c? (when (< (pulse self) 100) (speech self))))))
(defobserver names ((self person) new-names)
(format t "~&you can call me ~a" new-names))
......@@ -124,6 +134,8 @@
;;
(ct-assert (null (thought p)))))
(def-cell-test cv-test-person-3 ()
;; -------------------------------------------------------
;; dynamic dependency graph maintenance
......@@ -154,6 +166,7 @@
(setf (pulse p) 50)
(ct-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought)))))))
(def-cell-test cv-test-person-4 ()
(let ((p (make-instance 'person
:names '("speedy" "chill")
......@@ -167,8 +180,10 @@
;; - all cells accessed are constant.
;;
(ct-assert (null (md-slot-cell p 'speech)))
(ct-assert (assoc 'speech (cells-flushed p)))
(ct-assert (c-optimized-away-p (cdr (assoc 'speech (cells-flushed p)))))
#-its-alive!
(progn
(ct-assert (assoc 'speech (cells-flushed p)))
(ct-assert (c-optimized-away-p (cdr (assoc 'speech (cells-flushed p))))))
(ct-assert (not (c-optimized-away-p (md-slot-cell p 'thought)))) ;; pulse is variable, so cannot opti
(ct-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought))))) ;; but speech is opti, so only 1 used
......@@ -195,6 +210,8 @@
;; make sure cyclic dependencies are trapped:
;;
(cells-reset)
#+its-alive! t
#-its-alive!
(ct-assert
(handler-case
(progn
......@@ -205,10 +222,9 @@
(length (names self)))))
nil)
(t (error)
(describe error)
(describe error)
(setf *stop* nil)
t)))
)
t))))
;;
;; we'll toss off a quick class to test tolerance of cyclic
......
......@@ -69,15 +69,21 @@ subclass for them?)
(defun test-cells ()
(loop for test in (reverse *cell-tests*)
when t ; (eq 'cv-test-person-5 test)
do (cell-test-init test)
(funcall test))
(print (make-string 40 :initial-element #\*))
(print (make-string 40 :initial-element #\*))
(print "*** Cells-test successfully completed **")
(print (make-string 40 :initial-element #\*))
(print (make-string 40 :initial-element #\*)))
(dribble "c:/0algebra/cells-test.txt")
(progn ;prof:with-profiling (:type :time)
(time
(progn
(loop for test in (reverse *cell-tests*)
when t ; (eq 'cv-test-person-5 test)
do (cell-test-init test)
(funcall test))
(print (make-string 40 :initial-element #\*))
(print (make-string 40 :initial-element #\*))
(print "*** Cells-test successfully completed **")
(print (make-string 40 :initial-element #\*))
(print (make-string 40 :initial-element #\*)))))
;(prof:show-call-graph)
(dribble))
(defun cell-test-init (name)
(print (make-string 40 :initial-element #\!))
......
......@@ -33,8 +33,9 @@
(:file "family")
(:file "fm-utilities")
(:file "family-values")
(:file "test-propagation")
(:file "cells-store")))
(:file "test-propagation")
(:file "cells-store")
(:file "test-cc")))
(defmethod perform ((o load-op) (c (eql (find-system :cells))))
(pushnew :cells *features*))
......
......@@ -31,17 +31,17 @@ a cellular slot (or in a list in such) and then mop those up on not-to-be.
|#
(eval-when (compile load)
(proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3))))
(in-package :cells)
(defparameter *c-prop-depth* 0)
(defparameter *causation* nil)
(defparameter *data-pulse-id* 0)
(define-symbol-macro .dpid *data-pulse-id*)
(defparameter *finbiz-id* 0) ;; debugging tool only
(define-symbol-macro .fbid *finbiz-id*)
(export! .dpid .fbid)
(defparameter *c-debug* nil)
(defparameter *defer-changes* nil)
(defparameter *within-integrity* nil)
......@@ -50,6 +50,9 @@ a cellular slot (or in a list in such) and then mop those up on not-to-be.
(defparameter *unfinished-business* nil)
(defparameter *not-to-be* nil)
(defparameter *awake* nil)
(defparameter *awake-ct* nil)
#+test
(cells-reset)
......@@ -58,7 +61,11 @@ a cellular slot (or in a list in such) and then mop those up on not-to-be.
(setf
*c-debug* debug
*c-prop-depth* 0
*awake-ct* nil
*awake* nil
*not-to-be* nil
*data-pulse-id* 0
*finbiz-id* 0
*defer-changes* nil ;; should not be necessary, but cannot be wrong
*client-queue-handler* client-queue-handler
*within-integrity* nil
......@@ -77,7 +84,10 @@ a cellular slot (or in a list in such) and then mop those up on not-to-be.
(defun c-stopped ()
*stop*)
(export! .stopped)
(export! .stopped .cdbg)
(define-symbol-macro .cdbg
*c-debug*)
(define-symbol-macro .stopped
(c-stopped))
......
;; -*- lisp-version: "8.1 [Windows] (Apr 3, 2008 23:47)"; cg: "1.103.2.10"; -*-
;; -*- lisp-version: "8.1 [Windows] (Oct 11, 2008 17:00)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
......@@ -25,9 +25,11 @@
(make-instance 'module :name "fm-utilities.lisp")
(make-instance 'module :name "family-values.lisp")
(make-instance 'module :name "test-propagation.lisp")
(make-instance 'module :name "cells-store.lisp"))
(make-instance 'module :name "cells-store.lisp")
(make-instance 'module :name "test-cc.lisp"))
:projects (list (make-instance 'project-module :name
"utils-kt\\utils-kt"))
"utils-kt\\utils-kt" :show-modules
nil))
:libraries nil
:distributed-files nil
:internally-loaded-files nil
......@@ -48,7 +50,8 @@
:old-space-size 256000
:new-space-size 6144
:runtime-build-option :standard
:on-initialization 'cells::tcprop
:build-number 0
:on-initialization 'cells::test-with-cc
:on-restart 'do-default-restart)
;; End of Project Definition
......@@ -58,28 +58,38 @@ See the Lisp Lesser GNU Public License for more details.
(defmacro c? (&body body)
`(make-c-dependent
:code ',body
:code #+its-alive! nil #-its-alive! ',body
:value-state :unevaluated
:rule (c-lambda ,@body)))
(defmacro c?+n (&body body)
`(make-c-dependent
:inputp t
:code ',body
:code #+its-alive! nil #-its-alive! ',body
:value-state :unevaluated
:rule (c-lambda ,@body)))
(defmacro c?n (&body body)
`(make-c-dependent
:code '(without-c-dependency ,@body)
:code #+its-alive! nil #-its-alive! '(without-c-dependency ,@body)
:inputp t
:value-state :unevaluated
:rule (c-lambda (without-c-dependency ,@body))))
(export! c?n-dbg)
(defmacro c?n-dbg (&body body)
`(make-c-dependent
:code #+its-alive! nil #-its-alive! '(without-c-dependency ,@body)
:inputp t
:debug t
:value-state :unevaluated
:rule (c-lambda (without-c-dependency ,@body))))
(defmacro c?n-until (args &body body)
`(make-c-dependent
:optimize :when-value-t
:code ',body
:code #+its-alive! nil #-its-alive! ',body
:inputp t
:value-state :unevaluated
:rule (c-lambda ,@body)
......@@ -87,14 +97,14 @@ See the Lisp Lesser GNU Public License for more details.
(defmacro c?once (&body body)
`(make-c-dependent
:code '(without-c-dependency ,@body)
:code #+its-alive! nil #-its-alive! '(without-c-dependency ,@body)
:inputp nil
:value-state :unevaluated
:rule (c-lambda (without-c-dependency ,@body))))
(defmacro c_1 (&body body)
`(make-c-dependent
:code '(without-c-dependency ,@body)
:code #+its-alive! nil #-its-alive! '(without-c-dependency ,@body)
:inputp nil
:lazy t
:value-state :unevaluated
......@@ -105,14 +115,14 @@ See the Lisp Lesser GNU Public License for more details.
(defmacro c?dbg (&body body)
`(make-c-dependent
:code ',body
:code #+its-alive! nil #-its-alive! ',body
:value-state :unevaluated
:debug t
:rule (c-lambda ,@body)))
(defmacro c?_ (&body body)
`(make-c-dependent
:code ',body
:code #+its-alive! nil #-its-alive! ',body
:value-state :unevaluated
:lazy t
:rule (c-lambda ,@body)))
......@@ -120,7 +130,7 @@ See the Lisp Lesser GNU Public License for more details.
(defmacro c_? (&body body)
"Lazy until asked, then eagerly propagating"
`(make-c-dependent
:code ',body
:code #+its-alive! nil #-its-alive! ',body
:value-state :unevaluated
:lazy :until-asked
:rule (c-lambda ,@body)))
......@@ -128,7 +138,7 @@ See the Lisp Lesser GNU Public License for more details.
(defmacro c_?dbg (&body body)
"Lazy until asked, then eagerly propagating"
`(make-c-dependent
:code ',body
:code #+its-alive! nil #-its-alive! ',body
:value-state :unevaluated
:lazy :until-asked
:rule (c-lambda ,@body)
......@@ -155,7 +165,7 @@ See the Lisp Lesser GNU Public License for more details.
(defmacro c-formula ((&rest keys &key lazy &allow-other-keys) &body forms)
(assert (member lazy '(nil t :once-asked :until-asked :always)))
`(make-c-dependent
:code ',forms
:code #+its-alive! nil #-its-alive! ',forms
:value-state :unevaluated
:rule (c-lambda ,@forms)
,@keys))
......@@ -173,6 +183,14 @@ See the Lisp Lesser GNU Public License for more details.
:value-state :valid
:value ,value))
(export! c-in-lazy c_in)
(defmacro c-in-lazy (&body body)
`(c-input (:lazy :once-asked) (progn ,@body)))
(defmacro c_in (&body body)
`(c-input (:lazy :once-asked) (progn ,@body)))
(defmacro c-input-dbg (&optional (value nil valued-p))
`(make-cell
:inputp t
......
......@@ -21,107 +21,110 @@ See the Lisp Lesser GNU Public License for more details.
;;(print `(defmodel sees directsupers ,directsupers using ,(or directsupers :model-object)))
(assert (not (find class directsupers))() "~a cannot be its own superclass" class)
`(progn
(eval-when (:compile-toplevel :execute :load-toplevel)
(setf (get ',class :cell-types) nil)
(setf (get ',class 'slots-excluded-from-persistence)
',(loop for slotspec in slotspecs
unless (and (getf (cdr slotspec) :ps t)
(getf (cdr slotspec) :persistable t))
collect (car slotspec))))
(setf (get ',class :cell-types) nil)
(setf (get ',class 'slots-excluded-from-persistence)
(loop for slotspec in ',slotspecs
unless (and (getf (cdr slotspec) :ps t)
(getf (cdr slotspec) :persistable t))
collect (car slotspec)))
(loop for slotspec in ',slotspecs
do (destructuring-bind
(slotname &rest slotargs
&key (cell t)
&allow-other-keys)
slotspec
(declare (ignorable slotargs))
(when cell
(setf (md-slot-cell-type ',class slotname) cell))))
;; define slot macros before class so they can appear in
;; initforms and default-initargs
,@(delete nil
(loop for slotspec in slotspecs
nconcing (destructuring-bind
(slotname &rest slotargs
&key (cell t) owning (accessor slotname) reader
&allow-other-keys)
slotspec
(declare (ignorable slotargs owning))
(list
(when cell
(let* ((reader-fn (or reader accessor))
(deriver-fn (intern$ "^" (symbol-name reader-fn))))
`(eval-when (:compile-toplevel :execute :load-toplevel)
(unless (macro-function ',deriver-fn)
(defmacro ,deriver-fn ()
`(,',reader-fn self)))
#+sbcl (unless (fboundp ',reader-fn)
(defgeneric ,reader-fn (slot))))))))))
;; initforms and default-initargs
,@(loop for slotspec in slotspecs
nconcing (destructuring-bind
(slotname &rest slotargs
&key (cell t) (accessor slotname) reader
&allow-other-keys)
slotspec
(declare (ignorable slotargs ))
(when cell
(list (let* ((reader-fn (or reader accessor))
(deriver-fn (intern$ "^" (symbol-name reader-fn))))
`(eval-when (:compile-toplevel :execute :load-toplevel)
(unless (macro-function ',deriver-fn)
(defmacro ,deriver-fn ()
`(,',reader-fn self)))
#+sbcl (unless (fboundp ',reader-fn)
(defgeneric ,reader-fn (slot)))))))))
;
; ------- defclass --------------- (^slot-value ,model ',',slotname)
;
(eval-now! ;; suppress style warning in SBCL
(prog1
(defclass ,class ,(or directsupers '(model-object)) ;; now we can def the class
,(mapcar (lambda (s)
(list* (car s)
(let ((ias (cdr s)))
(remf ias :persistable)
(remf ias :ps)
;; We handle accessor below
(when (getf ias :cell t)
(remf ias :reader)
(remf ias :writer)
(remf ias :accessor))
(remf ias :cell)
(remf ias :owning)
(remf ias :unchanged-if)
ias))) (mapcar #'copy-list slotspecs))
(:documentation
,@(or (cdr (find :documentation options :key #'car))
'("chya")))
(:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this
,@(cdr (find :default-initargs options :key #'car)))
(:metaclass ,(or (cadr (find :metaclass options :key #'car))
'standard-class)))
(prog1
(defclass ,class ,(or directsupers '(model-object)) ;; now we can def the class
,(mapcar (lambda (s)
(list* (car s)
(let ((ias (cdr s)))
(remf ias :persistable)
(remf ias :ps)
;; We handle accessor below
(when (getf ias :cell t)
(remf ias :reader)
(remf ias :writer)
(remf ias :accessor))
(remf ias :cell)
(remf ias :owning)
(remf ias :unchanged-if)
ias))) (mapcar #'copy-list slotspecs))
(:documentation
,@(or (cdr (find :documentation options :key #'car))
'("chya")))
(:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this
,@(cdr (find :default-initargs options :key #'car)))
(:metaclass ,(or (cadr (find :metaclass options :key #'car))
'standard-class)))
(defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key)
(declare (ignore slot-names iargs))
,(when (and directsupers (not (member 'model-object directsupers)))
`(unless (typep self 'model-object)
(error "If no superclass of ~a inherits directly
(defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key)
(declare (ignore slot-names iargs))
,(when (and directsupers (not (member 'model-object directsupers)))
`(unless (typep self 'model-object)
(error "If no superclass of ~a inherits directly
or indirectly from model-object, model-object must be included as a direct super-class in
the defmodel form for ~a" ',class ',class))))
;
; slot accessors once class is defined...
;
,@(mapcar (lambda (slotspec)
(destructuring-bind
(slotname &rest slotargs
&key (cell t) owning unchanged-if (accessor slotname) reader writer type
&allow-other-keys)
slotspec
;
; slot accessors once class is defined...
;
,@(mapcar (lambda (slotspec)
(destructuring-bind
(slotname &rest slotargs
&key (cell t) unchanged-if (accessor slotname) reader writer type
&allow-other-keys)
slotspec
(declare (ignorable slotargs))
(when cell
(let* ((reader-fn (or reader accessor))
(writer-fn (or writer accessor))
)
`(eval-when (#-sbcl :compile-toplevel :load-toplevel :execute) ; ph -- prevent sbcl warning
(setf (md-slot-cell-type ',class ',slotname) ,cell)
,(when owning
`(setf (md-slot-owning-direct? ',class ',slotname) ,owning))
,(when reader-fn
`(defmethod ,reader-fn ((self ,class))
(md-slot-value self ',slotname)))
,(when writer-fn
`(defmethod (setf ,writer-fn) (new-value (self ,class))
(setf (md-slot-value self ',slotname)
,(if type
`(coerce new-value ',type)
'new-value))))
,(when unchanged-if
`(def-c-unchanged-test (,class ,slotname) ,unchanged-if))
)
))
))
slotspecs)))))
(declare (ignorable slotargs))
(when cell
(let* ((reader-fn (or reader accessor))
(writer-fn (or writer accessor))
)
`(progn