Permalink
Browse files

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.
  • Loading branch information...
1 parent f78e053 commit c2218d1df686ccd7f9af178d3d32ebe1ac789c9d ktilton committed Mar 15, 2008
Showing with 154 additions and 52 deletions.
  1. +1 −1 cells-manifesto.txt
  2. +6 −1 cells.lisp
  3. +1 −1 defpackage.lisp
  4. +3 −3 initialize.lisp
  5. +12 −12 link.lisp
  6. +3 −2 md-slot-value.lisp
  7. +18 −4 propagate.lisp
  8. +4 −5 synapse.lisp
  9. +1 −1 trc-eko.lisp
  10. +1 −1 utils-kt/debug.lisp
  11. +2 −12 utils-kt/detritus.lisp
  12. +23 −3 utils-kt/flow-control.lisp
  13. +78 −5 utils-kt/quad.lisp
  14. +1 −1 utils-kt/utils-kt.lpr
View
@@ -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
View
@@ -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)
View
@@ -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
View
@@ -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))
View
@@ -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)
View
@@ -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)
View
@@ -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)
View
@@ -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)))))
View
@@ -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)
View
@@ -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)
View
@@ -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")
View
@@ -113,18 +113,29 @@ 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))
(if ,bindvar
,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 ()
Oops, something went wrong.

0 comments on commit c2218d1

Please sign in to comment.