[cells-cvs] CVS update: cells/link.lisp cells/md-slot-value.lisp - cells-cvs@common-lisp.net - mailman3.common-lisp.net

21 May 2005

Update of /project/cells/cvsroot/cells
In directory common-lisp.net:/tmp/cvs-serv10097
Modified Files:
    link.lisp md-slot-value.lisp 
Log Message:
Mo' better tuning, esp. of c-link-ex
Date: Sat May 21 17:13:12 2005
Author: ktilton
Index: cells/link.lisp
diff -u cells/link.lisp:1.3 cells/link.lisp:1.4

--- cells/link.lisp:1.3	Thu May 19 22:17:47 2005
+++ cells/link.lisp	Sat May 21 17:13:12 2005
@@ -22,11 +22,14 @@
(in-package :cells)
+(eval-when (compile load)
+ (proclaim '(optimize (speed 3) (safety 0) (space 0) (debug 0))))
+
+
 (defun c-link-ex (used &aux (user (car *c-calculators*)))
   (c-assert user)
-  (assert used)
-  (when (or (c-optimized-away-p used)
-          (not (typep used 'cell)))
+  (c-assert used)
+  (when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell
     (return-from c-link-ex nil))
@@ -43,51 +46,55 @@
   (c-assert (not (eq :eternal-rest (md-state (c-model used)))))
   (count-it :c-link-entry)
-;;;  (loop for ku in (c-usesds user)
-;;;        for posn upfrom 0
-;;;        wh
-
-;;;  (loop with prior-used = 0
-;;;        and found = nil
-;;;        for known-used in (c-useds user)
-;;;        when (eq known-used used)
-;;;        do (progn
-;;;             (setf found t)
-;;;             (loop-finish))
-;;;        finally (return (- *cd-usagect*
-;;;                (- (length (cd-useds user))
-;;;                  (or (position used (cd-useds user)) 0)))))
-        
-  (if (find used (c-useds user))
-      (count-it :known-used)
-    (progn
+  (multiple-value-bind (used-pos useds-len)
+      (loop with u-pos
+          for known in (cd-useds user)
+          counting known into length
+            ;; do (print (list :data known length))
+          when (eq used known)
+          do
+            (count-it :known-used)
+            (setf u-pos (1- length))
+          finally (return (values u-pos length)))
+
+    (when (null used-pos)
       (trc nil "c-link > new user,used " user used)
       (count-it :new-used)
+      (incf useds-len)
+      (setf used-pos 0)
       (push user (c-users used))
-      (push used (cd-useds user))))
+      (push used (cd-useds user)))
-  (let ((mapn (get-mapn used (cd-useds user))
-          #+not (- *cd-usagect*
-                  (- (length (cd-useds user))
-                    (or (position used (cd-useds user)) 0)))))
-    ;; (trc user "c-link> setting usage bit" user mapn used)
-    (if (minusp mapn)
-        (c-break "whoa. more than ~d used by ~a? i see ~d"
-          *cd-usagect* user (length (cd-useds user)))
-      (cd-usage-set user mapn)))
+    (let ((mapn (- *cd-usagect*
+                  (- useds-len used-pos))))
+      ;; (trc user "c-link> setting usage bit" user mapn used)
+      (if (minusp mapn)
+          (c-break "whoa. more than ~d used by ~a? i see ~d"
+            *cd-usagect* user (length (cd-useds user)))
+        (cd-usage-set user mapn))))
   used)
-
+#+test
+(dotimes (used 3)
+  (print (multiple-value-bind (p l)
+             (loop with u-pos
+                 for known in '(0 2)
+                 counting known into length
+                   ;; do (print (list :data known length))
+                 when (eql used known) do (setf u-pos (1- length))
+                 finally (return (values u-pos length)))
+           (list p l))))
 #+TEST
 (dotimes (n 3)
   (trc "mapn" n (get-mapn n '(0 1 2))))
(defun get-mapn (seek map)
+  (declare (fixnum *cd-usagect*))
   (- *cd-usagect*
     (loop with seek-pos = nil
           for m in map
-          for pos upfrom 0
-          counting m into m-len
-          when (eql seek m)
+          for pos fixnum upfrom 0
+          counting m into m-len fixnum
+          when (eq seek m)
           do (setf seek-pos pos)
           finally (return (- m-len seek-pos)))))
Index: cells/md-slot-value.lisp
diff -u cells/md-slot-value.lisp:1.7 cells/md-slot-value.lisp:1.8
--- cells/md-slot-value.lisp:1.7	Sat May 21 03:40:53 2005
+++ cells/md-slot-value.lisp	Sat May 21 17:13:12 2005
@@ -58,7 +58,13 @@
    ((c-inputp c))
    ((c-currentp c))
    ((or (not (c-validp c)) 
-      (c-influenced-by-pulse c))
+      (some (lambda (used)
+              (c-value-ensure-current used)
+              (when (and (c-changed used) (> (c-pulse used)(c-pulse c)))
+                #+chya (trc nil "used changed" used :asker c
+                         :inpulse ip :pulse *data-pulse-id*)
+                t))
+        (cd-useds c)))
     (c-calculate-and-set c))
    (t (c-pulse-update c :valid-uninfluenced)))
@@ -67,18 +73,7 @@
     (error 'unbound-cell :instance (c-model c) :name (c-slot-name c)))
(c-value c))
-
-(defun c-influenced-by-pulse (c); &aux (ip *data-pulse-id*))
-  (unless (c-currentp c)
-    (count-it :c-influenced-by-pulse)
-    (trc nil "c-influenced-by-pulse> " c (c-useds c))
-    (some (lambda (used)
-            (c-value-ensure-current used)
-            (when (and (c-changed used) (> (c-pulse used)(c-pulse c)))
-              #+chya (trc nil "used changed" used :asker c
-                :inpulse ip :pulse *data-pulse-id*)
-              t))
-      (c-useds c))))
+ ;; 2005-05-21 was c-useds, but I think these are c-dependents
(defun c-calculate-and-set (c)
   (flet ((body ()

    