Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

245 lines (200 sloc) 8.946 kb
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
#|
Cells -- Automatic Dataflow Managememnt
Copyright (C) 1995, 2006 by Kenneth Tilton
This library is free software; you can redistribute it and/or
modify it under the terms of the Lisp Lesser GNU Public License
(http://opensource.franz.com/preamble.html), known as the LLGPL.
This library is distributed WITHOUT ANY WARRANTY; without even
the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the Lisp Lesser GNU Public License for more details.
|#
(in-package :cells)
(defun md-awake (self) (eql :awake (md-state self)))
(defun fm-grandparent (md)
(fm-parent (fm-parent md)))
(defmethod md-release (other)
(declare (ignorable other)))
(export! mdead)
;___________________ birth / death__________________________________
(defgeneric mdead (self)
(:method ((self model-object))
(unless *not-to-be* ;; weird
(eq :eternal-rest (md-state self))))
(:method (self)
(declare (ignore self))
nil))
(defgeneric not-to-be (self)
(:method (other)
(declare (ignore other)))
(:method ((self cons))
(not-to-be (car self))
(not-to-be (cdr self)))
(:method ((self array))
(loop for s across self
do (not-to-be s)))
(:method ((self hash-table))
(maphash (lambda (k v)
(declare (ignorable k))
(not-to-be v)) self))
(:method ((self model-object))
(setf (md-census-count self) -1)
(md-quiesce self))
(:method :before ((self model-object))
(loop for slot-name in (md-owning-slots self)
do (not-to-be (slot-value self slot-name))))
(:method :around ((self model-object))
(declare (ignorable self))
(let ((*not-to-be* t)
(dbg nil))
(flet ((gok ()
(if (eq (md-state self) :eternal-rest)
(trc nil "n2be already dead" self)
(progn
(call-next-method)
(setf (fm-parent self) nil
(md-state self) :eternal-rest)
;;; (bif (a (assoc (type-of self) *awake-ct*))
;;; (decf (cdr a))
;;; (break "no awake for" (type-of self) *awake-ct*))
;;; (setf *awake* (delete self *awake*))
(md-map-cells self nil
(lambda (c)
(c-assert (eq :quiesced (c-state c)) ()
"Cell ~a of dead model ~a not quiesced. Was not-to-be shadowed by
a primary method? Use :before instead." c self))) ;; fails if user obstructs not.to-be with primary method (use :before etc)
))))
(if (not dbg)
(gok)
(wtrc (0 100 "not.to-be nailing" self (when (typep self 'family)
(mapcar 'type-of (slot-value self '.kids))))
(gok)
(when dbg (trc "finished nailing" self))))))))
(defun md-quiesce (self)
(trc nil "md-quiesce nailing cells" self (type-of self))
(md-map-cells self nil (lambda (c)
(trc nil "quiescing" c)
(c-assert (not (find c *call-stack*)))
(c-quiesce c)))
(when (register? self)
(fm-check-out self)))
(defun c-quiesce (c)
(typecase c
(cell
(trc nil "c-quiesce unlinking" c)
(c-unlink-from-used c)
(dolist (caller (c-callers c))
(setf (c-value-state caller) :uncurrent)
(trc nil "c-quiesce totlalaly unlinking caller and making uncurrent" .dpid :q c :caller caller)
(c-unlink-caller c caller))
(setf (c-state c) :quiesced) ;; 20061024 for debugging for now, might break some code tho
)))
(defparameter *to-be-dbg* nil)
(defmacro make-kid (class &rest initargs)
`(make-instance ,class
,@initargs
:fm-parent (progn (assert self) self)))
(defvar *c-d-d*)
(defvar *max-d-d*)
(defparameter *model-pop* nil)
(export! md-census-start md-census-report md-census-count)
(defun md-census-start ()
(setf *model-pop* (make-hash-table :test 'eq)))
(defun (setf md-census-count) (delta self)
(when *model-pop*
(incf (gethash (type-of self) *model-pop* 0) delta)))
(defun md-census-report ()
(when *model-pop*
(loop for (ct . type)
in (sort (let (raw)
(maphash (lambda (k v)
(push (cons v k) raw))
*model-pop*)
raw) '< :key 'car)
unless (zerop ct)
do (trc "pop" ct type))))
#+test
(md-census-report)
#+test
(md-census-count)
(defun md-census-count (&optional type)
(when *model-pop*
(if type
(gethash type *model-pop* 0)
(loop for v being the hash-values of *model-pop*
summing v))))
(defun count-model (self &key count-cells &aux (ccc 0))
(setf *c-d-d* (make-hash-table :test 'eq) *max-d-d* 0)
(let ((*counted* (make-hash-table :test 'eq :size 5000)))
(with-metrics (t nil "cells statistics for" self)
(labels ((cc (self from)
(unless (gethash self *counted*)
(setf (gethash self *counted*) t)
(typecase self
(cons (cc (car self) from)
(cc (cdr self) from))
#+nahhhh (mathx::box (count-it! :mathx-box-struct)
(cc (mathx::bx-mx self) from))
(model
(when (zerop (mod (incf ccc) 100))
(trc "cc" (md-name self) (type-of self)))
(count-it! :thing)
(count-it! :thing (type-of self))
#+nahhhh (when (typep self 'mathx::problem)
(count-it! :thing-from (type-of self) (type-of from)))
(when count-cells
(loop for (nil . c) in (cells self)
do (count-it! :live-cell)
;(count-it! :live-cell id)
(when (c-lazy c)
(count-it! :lazy)
(count-it! :lazy (c-value-state c)))
(typecase c
(c-dependent
(count-it! :dependent-cell)
#+chill (loop repeat (length (c-useds c))
do (count-it! :cell-useds)
(count-it! :dep-depth (c-depend-depth c))))
(otherwise (if (c-inputp c)
(progn
(count-it! :c-input-altogether)
;(count-it! :c-input id)
)
(count-it! :c-unknown))))
(loop repeat (length (c-callers c))
do (count-it! :cell-callers)))
(loop repeat (length (cells-flushed self))
do (count-it! :flushed-cell #+toomuchinfo id)))
(loop for slot in (md-owning-slots self) do
(loop for k in (let ((sv (SLOT-VALUE self slot)))
(if (listp sv) sv (list sv)))
do (cc k self)))
#+nahhh
(progn
(when (typep self 'mathx::mx-optr)
(cc (mathx::opnds self) from))
(when (typep self 'mathx::math-expression)
(count-it! :math-expression))))
(otherwise
(count-it (type-of self)))))))
(cc self nil)))))
(defun c-depend-depth (ctop)
(if (null (c-useds ctop))
0
(or (gethash ctop *c-d-d*)
(labels ((cdd (c &optional (depth 1) chain)
(when (and (not (c-useds c))
(> depth *max-d-d*))
(setf *max-d-d* depth)
(trc "new dd champ from user" depth :down-to c)
(when (= depth 41)
(trc "end at" (c-slot-name c) :of (type-of (c-model c)))
(loop for c in chain do
(trc "called by" (c-slot-name c) :of (type-of (c-model c))))))
(setf (gethash c *c-d-d*)
;(break "c-depend-depth ~a" c)
(progn
;(trc "dd" c)
(1+ (loop for u in (c-useds c)
maximizing (cdd u (1+ depth) (cons c chain))))))))
(cdd ctop)))))
Jump to Line
Something went wrong with that request. Please try again.