Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 154 lines (126 sloc) 5.522 kb
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells p...
ktilton authored
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
8faef55 A slow tedious transition to LLGPL
ktilton authored
2 #|
3
4 Cells -- Automatic Dataflow Managememnt
5
6 Copyright (C) 1995, 2006 by Kenneth Tilton
7
8 This library is free software; you can redistribute it and/or
9 modify it under the terms of the Lisp Lesser GNU Public License
10 (http://opensource.franz.com/preamble.html), known as the LLGPL.
11
12 This library is distributed WITHOUT ANY WARRANTY; without even
13 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
14
15 See the Lisp Lesser GNU Public License for more details.
16
17 |#
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells p...
ktilton authored
18
19 (in-package :cells)
20
c2218d1 Mostly differentiating new *depender* from CAR of *call-stack* so we can...
ktilton authored
21 (defun record-caller (used)
f3cb1ef Mo' better tuning, esp. of c-link-ex
ktilton authored
22 (when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell
c2218d1 Mostly differentiating new *depender* from CAR of *call-stack* so we can...
ktilton authored
23 (trc nil "depender not being recorded because used optimized away" *depender* (c-value used) :used used)
4b24693 New abbreviated defmodel: defmd
ktilton authored
24 (return-from record-caller nil))
8e89a4c Just trying to get a patch in for record-caller
ktilton authored
25 #+shhh (trc *depender* "record-caller depender entry: used=" used :caller *depender*)
26 (assert *depender*)
27 #+shhh (trc used "record-caller caller entry: used=" (qci used)
28 :caller *depender*)
29
f3cb1ef Mo' better tuning, esp. of c-link-ex
ktilton authored
30 (multiple-value-bind (used-pos useds-len)
31 (loop with u-pos
c2218d1 Mostly differentiating new *depender* from CAR of *call-stack* so we can...
ktilton authored
32 for known in (cd-useds *depender*)
f3cb1ef Mo' better tuning, esp. of c-link-ex
ktilton authored
33 counting known into length
34 when (eq used known)
35 do
36 (count-it :known-used)
bc4bea8 Remove limitation on number of dependencies one cell can have.
ktilton authored
37 (setf u-pos length)
38 finally (return (values (when u-pos (- length u-pos)) length)))
f39e94e Speed up c-link-ex a little
ktilton authored
39
f3cb1ef Mo' better tuning, esp. of c-link-ex
ktilton authored
40 (when (null used-pos)
c2218d1 Mostly differentiating new *depender* from CAR of *call-stack* so we can...
ktilton authored
41 (trc nil "c-link > new caller,used " *depender* used)
f39e94e Speed up c-link-ex a little
ktilton authored
42 (count-it :new-used)
bc4bea8 Remove limitation on number of dependencies one cell can have.
ktilton authored
43 (setf used-pos useds-len)
c2218d1 Mostly differentiating new *depender* from CAR of *call-stack* so we can...
ktilton authored
44 (push used (cd-useds *depender*))
45 (caller-ensure used *depender*) ;; 060604 experiment was in unlink
41023db evolving geometry; refinement of test case 01c-cascade
ktilton authored
46 )
8e89a4c Just trying to get a patch in for record-caller
ktilton authored
47 (let ((cd-usage (cd-usage *depender*)))
48 (when (>= used-pos (array-dimension cd-usage 0))
49 (setf cd-usage
50 (setf (cd-usage *depender*)
51 (adjust-array (cd-usage *depender*)
52 (+ used-pos 16)
53 :initial-element 0))))
54 (setf (sbit cd-usage used-pos) 1))
55 #+nonportable
bc4bea8 Remove limitation on number of dependencies one cell can have.
ktilton authored
56 (handler-case
c2218d1 Mostly differentiating new *depender* from CAR of *call-stack* so we can...
ktilton authored
57 (setf (sbit (cd-usage *depender*) used-pos) 1)
bc4bea8 Remove limitation on number of dependencies one cell can have.
ktilton authored
58 (type-error (error)
59 (declare (ignorable error))
c2218d1 Mostly differentiating new *depender* from CAR of *call-stack* so we can...
ktilton authored
60 (setf (cd-usage *depender*)
61 (adjust-array (cd-usage *depender*) (+ used-pos 16) :initial-element 0))
62 (setf (sbit (cd-usage *depender*) used-pos) 1))))
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells p...
ktilton authored
63 used)
bc4bea8 Remove limitation on number of dependencies one cell can have.
ktilton authored
64
65
df44f32 *** empty log message ***
ktilton authored
66 ;--- unlink unused --------------------------------
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells p...
ktilton authored
67
852b833 CVS sucks
ktilton authored
68 (defun c-unlink-unused (c &aux (usage (cd-usage c))
69 (usage-size (array-dimension (cd-usage c) 0))
d565d12 nothing special
ktilton authored
70 (dbg nil))
afa428a a couple of serious bug fixes, actually.
ktilton authored
71 (declare (ignorable dbg usage-size))
bc4bea8 Remove limitation on number of dependencies one cell can have.
ktilton authored
72 (when (cd-useds c)
73 (let (rev-pos)
74 (labels ((nail-unused (useds)
75 (flet ((handle-used (rpos)
852b833 CVS sucks
ktilton authored
76 (if (or (>= rpos usage-size)
77 (zerop (sbit usage rpos)))
bc4bea8 Remove limitation on number of dependencies one cell can have.
ktilton authored
78 (progn
79 (count-it :unlink-unused)
8e89a4c Just trying to get a patch in for record-caller
ktilton authored
80 (trc nil "c-unlink-unused" c :dropping-used (car useds))
4b24693 New abbreviated defmodel: defmd
ktilton authored
81 (c-unlink-caller (car useds) c)
bc4bea8 Remove limitation on number of dependencies one cell can have.
ktilton authored
82 (rplaca useds nil))
41023db evolving geometry; refinement of test case 01c-cascade
ktilton authored
83 (progn
4b24693 New abbreviated defmodel: defmd
ktilton authored
84 ;; moved into record-caller 060604 (caller-ensure (car useds) c)
41023db evolving geometry; refinement of test case 01c-cascade
ktilton authored
85 )
86 )))
bc4bea8 Remove limitation on number of dependencies one cell can have.
ktilton authored
87 (if (cdr useds)
88 (progn
89 (nail-unused (cdr useds))
90 (handle-used (incf rev-pos)))
91 (handle-used (setf rev-pos 0))))))
afa428a a couple of serious bug fixes, actually.
ktilton authored
92 (trc nil "cd-useds length" (length (cd-useds c)) c)
8e89a4c Just trying to get a patch in for record-caller
ktilton authored
93
bc4bea8 Remove limitation on number of dependencies one cell can have.
ktilton authored
94 (nail-unused (cd-useds c))
8e89a4c Just trying to get a patch in for record-caller
ktilton authored
95 (setf (cd-useds c) (delete nil (cd-useds c)))
96 (trc nil "useds of" c :now (mapcar 'qci (cd-useds c)))))))
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells p...
ktilton authored
97
4b24693 New abbreviated defmodel: defmd
ktilton authored
98 (defun c-caller-path-exists-p (from-used to-caller)
99 (count-it :caller-path-exists-p)
100 (or (find to-caller (c-callers from-used))
101 (find-if (lambda (from-used-caller)
102 (c-caller-path-exists-p from-used-caller to-caller))
103 (c-callers from-used))))
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells p...
ktilton authored
104
105 ; ---------------------------------------------
106
107 (defun cd-usage-clear-all (c)
8e89a4c Just trying to get a patch in for record-caller
ktilton authored
108 (setf (cd-usage c) (blank-usage-mask))
109 #+wowo (loop with mask = (cd-usage c)
110 for n fixnum below (array-dimension mask 0)
111 do (setf (sbit mask n) 0)
112 finally (return mask))
113 )
bc4bea8 Remove limitation on number of dependencies one cell can have.
ktilton authored
114
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells p...
ktilton authored
115
116 ;--- unlink from used ----------------------
117
4b24693 New abbreviated defmodel: defmd
ktilton authored
118 (defmethod c-unlink-from-used ((caller c-dependent))
119 (dolist (used (cd-useds caller))
afa428a a couple of serious bug fixes, actually.
ktilton authored
120 (trc nil "unlinking from used" caller used)
4b24693 New abbreviated defmodel: defmd
ktilton authored
121 (c-unlink-caller used caller))
122 ;; shouldn't be necessary (setf (cd-useds caller) nil)
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells p...
ktilton authored
123 )
124
125 (defmethod c-unlink-from-used (other)
126 (declare (ignore other)))
127
128 ;----------------------------------------------------------
129
4b24693 New abbreviated defmodel: defmd
ktilton authored
130 (defun c-unlink-caller (used caller)
3b95fb7 Some interesting changes
ktilton authored
131 (trc nil "(1) caller unlinking from (2) used" caller used)
4b24693 New abbreviated defmodel: defmd
ktilton authored
132 (caller-drop used caller)
133 (c-unlink-used caller used))
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells p...
ktilton authored
134
4b24693 New abbreviated defmodel: defmd
ktilton authored
135 (defun c-unlink-used (caller used)
136 (setf (cd-useds caller) (delete used (cd-useds caller))))
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells p...
ktilton authored
137
138 ;----------------- link debugging ---------------------
139
4b24693 New abbreviated defmodel: defmd
ktilton authored
140 (defun dump-callers (c &optional (depth 0))
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells p...
ktilton authored
141 (format t "~&~v,4t~s" depth c)
4b24693 New abbreviated defmodel: defmd
ktilton authored
142 (dolist (caller (c-callers c))
143 (dump-callers caller (+ 1 depth))))
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cells p...
ktilton authored
144
145 (defun dump-useds (c &optional (depth 0))
146 ;(c.trc "dump-useds> entry " c (+ 1 depth))
147 (when (zerop depth)
148 (format t "x~&"))
149 (format t "~&|usd> ~v,8t~s" depth c)
150 (when (typep c 'c-ruled)
151 ;(c.trc "its ruled" c)
152 (dolist (used (cd-useds c))
153 (dump-useds used (+ 1 depth)))))
Something went wrong with that request. Please try again.