/pliant/language/data/cache.pli
1	module "/pliant/install/ring2.pli"
2	module "/pliant/language/context/memory.pli"
3	module "/pliant/language/stream/stream.pli"
4
5	constant debug true
6
7	public
8	constant cache_class_timeout 0
9	constant cache_class_cheap 1
10	constant cache_class_standard 2
11	constant cache_class_costy 3
12	constant cache_class_should_keep 4 # if droped, will corrupt one client connection, not all of them
13	constant cache_class_must_keep 5 # never drop: would not crash the server, but seriously corrupt service
14
15	constant flag_class_bits (cast 15 Int)
16	constant class_count 6
17
18	constant flag_init 100h
19	constant flag_update 200h
20	constant flag_drop 400h
21	constant flag_dropped 800h
22
23
24	type CachePrototype
25	field ListNode_ list_node
26	field Str id # we should use a new data type so that we don't need two copies of the name, one here, and one in the dictionary
27	field Int flags
28
29	method p update stream -> status
30	oarg_rw CachePrototype p ; arg_rw Stream stream ; arg ExtendedStatus status
31	generic
32	status := failure "not implemented"
33
34	method p dump stream -> status
35	oarg_rw CachePrototype p ; arg_rw Stream stream ; arg ExtendedStatus status
36	generic
37	status := failure "not implemented"
38
39	method p sleep
40	oarg_rw CachePrototype p
41	generic
42
43	method p drop
44	oarg_rw CachePrototype p
45	generic
46
47	# update accordingly:
48	# /pliant/graphic/color/gamut.pli
49	# /pliant/storage/database/prototype.pli
50
51
52	gvar Dictionary cache
53	gvar (Array List_ class_count) lru
54	gvar Sem sem
55
56	method cp class -> c
57	arg CachePrototype cp ; arg Int c
58	c := cp:flags .and. flag_class_bits
59
60	method cp list -> l
61	arg CachePrototype cp ; arg_RW List_ l
62	l :> lru cp:class
63
64
65	method cp update_begin
66	arg_rw CachePrototype cp
67	cp flags := cp:flags .or. flag_update
68
69	method cp update_end
70	arg_rw CachePrototype cp
71	cp flags := cp:flags .and. .not. (cast flag_update Int)
72
73	method cp is_update -> c
74	arg CachePrototype cp ; arg CBool c
75	c := (cp:flags .and. flag_update)<>0
76
77
78	function cache_shrink mem class -> status
79	arg Int mem class ; arg Status status
80	part shrink
81	if memory_current_used<mem
82	return success
83	sem request
84	var Int c := 0
85	part scan
86	var Link:CachePrototype obj :> (addressof lru:c:first) map CachePrototype
87	while exists:obj and (addressof:obj map Int -2)<>2
88	obj :> (addressof obj:list_node:next) map CachePrototype
89	if not exists:obj and c<class
90	c += 1
91	restart scan
92	if exists:obj
93	obj:list remove obj:list_node
94	obj flags += flag_drop
95	sem release
96	if exists:obj
97	check (obj:flags .and. flag_init)=0 # there is no link, so it cannot be at init state
98	obj drop
99	sem request
100	cache remove obj:id addressof:obj
101	obj flags := flag_dropped
102	sem release
103	obj :> null map CachePrototype
104	restart shrink
105	status := failure
106
107	function cache_shrink -> status
108	arg Status status
109	status := cache_shrink memory_assigned cache_class_costy
110	if status=failure and memory_overflow=defined and memory_current_used>memory_assigned\2+memory_overflow\2
111	status := cache_shrink memory_assigned cache_class_should_keep
112
113
114	function broadcast_prototype object param fun
115	oarg_rw CachePrototype object ; arg_rw Universal param ; arg Function fun
116	indirect
117
118	function cache_broadcast fun param
119	arg Function fun ; arg_rw Universal param
120	sem request
121	for (var Int i) 0 lru:size-1
122	var Link:CachePrototype obj :> (addressof lru:i:first) map CachePrototype
123	while exists:obj
124	broadcast_prototype obj param fun
125	obj :> (addressof obj:list_node:next) map CachePrototype
126	sem release
127
128
129	function cache_open id type obj -> newone
130	arg Str id ; arg Type type ; arg_w Link:CachePrototype obj ; arg CBool newone
131	part fetch
132	cache_shrink
133	sem request
134	obj :> (cache first id) map CachePrototype
135	if exists:obj
136	if (obj:flags .and. flag_drop)=0
137	var Pointer:List_ l :> obj list
138	l remove obj:list_node
139	l append obj:list_node
140	newone := false
141	else
142	obj :> (entry_new type) map CachePrototype
143	obj id := id
144	obj flags := flag_init+cache_class_standard
145	cache insert id true addressof:obj
146	obj:list append obj:list_node
147	newone := true
148	sem release
149	if not newone
150	while (obj:flags .and. flag_init+flag_drop)<>0
151	os_yield
152	if (obj:flags .and. flag_dropped)<>0
153	restart fetch
154
155	function cache_ready obj
156	arg_rw Link:CachePrototype obj
157	sem request
158	obj flags -= flag_init
159	sem release
160
161	function cache_cancel obj
162	arg_rw Link:CachePrototype obj
163	sem request
164	cache remove obj:id addressof:obj
165	obj:list remove obj:list_node
166	obj flags := flag_dropped
167	sem release
168
169
170	function cache_setup obj class
171	arg_rw Link:CachePrototype obj ; arg Int class
172	sem request
173	if (obj:flags .and. flag_drop)=0
174	obj:list remove obj:list_node
175	obj flags := (obj:flags .and. .not. flag_class_bits) .or. class
176	obj:list append obj:list_node
177	sem release
178
179
180	function cache_search id obj -> found
181	arg Str id ; arg_w Link:CachePrototype obj ; arg CBool found
182	part fetch
183	sem rd_request
184	obj :> (cache first id) map CachePrototype
185	sem rd_release
186	found := exists obj
187	if found
188	while (obj:flags .and. flag_init+flag_drop)<>0
189	os_yield
190	if (obj:flags .and. flag_dropped)<>0
191	restart fetch
192
193
194	function cache_delete id
195	arg Str id
196	sem request
197	var Link:CachePrototype obj :> (cache first id) map CachePrototype
198	if exists:obj and (obj:flags .and. flag_drop)=0
199	cache remove id addressof:obj
200	obj:list remove obj:list_node
201	obj flags := flag_dropped
202	sem release
203	if exists:obj
204	while (obj:flags .and. flag_init+flag_drop)<>0
205	os_yield
206
207
208	export CachePrototype '. id' '. update' '. dump' '. sleep' '. drop'
209	export '. update_begin' '. update_end' '. is_update'
210	export cache_shrink
211	export cache_broadcast
212	export cache_open cache_setup cache_ready cache_cancel
213	export cache_search
214	export cache_delete
215
216
217	function clear_the_cache parameter
218	arg Address parameter
219	cache_shrink 0 cache_class_should_keep
220
221	gvar DelayedAction da
222	da function :> the_function clear_the_cache Address
223	pliant_shutdown_actions append addressof:da
224
225
226	doc
227	[Usage sequence is:]
228	listing
229	if (cache_open "/myorg/myapp/category/object_id" my_app_type 0 (var Link:CachePrototype obj))
230	# object setup code
231	cache_ready obj