/pliant/language/schedule/sem.pli
1	# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
2	#
3	# This program is free software; you can redistribute it and/or
4	# modify it under the terms of the GNU General Public License version 2
5	# as published by the Free Software Foundation.
6	#
7	# This program is distributed in the hope that it will be useful,
8	# but WITHOUT ANY WARRANTY; without even the implied warranty of
9	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
10	# GNU General Public License for more details.
11	#
12	# You should have received a copy of the GNU General Public License
13	# version 2 along with this program; if not, write to the Free Software
14	# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
15
16	scope "/pliant/language/" "/pliant/install/"
17	module "/pliant/install/ring2.pli"
18	module "pentium.pli"
19
20
21	constant trivial_yield_policy processor_count>1
22	constant not_too_unfair true
23
24	constant slice_fill processor_is_pentium and processor_count>1
25	constant slice_cycles 2^20 # number of processor cycles per time slice
26
27	constant busy_wait false
28	constant busy_sleep 2^9
29	constant busy_timeout 2^12
30
31
32	if slice_fill
33
34	function set_slice
35	var Pointer:ThreadHeader h :> current_thread_header
36	pentium_counter h:processor_counter_low h:processor_counter_high
37
38	function same_slice -> c
39	arg CBool c
40	pentium_counter (var uInt low) (var uInt high)
41	var Pointer:ThreadHeader h :> current_thread_header
42	c := ( high=h:processor_counter_high or (high .-. h:processor_counter_high)=1 and low<h:processor_counter_low ) and (low .-. h:processor_counter_low)<slice_cycles
43
44	else
45
46	function set_slice
47	void
48
49	constant same_slice false
50
51
52	constant not_locked 0
53	constant write_locked 80000000h
54	constant please_retry 0FFFFFFFFh
55
56	constant high_cost 1000000000
57
58
59	type Sem
60	field uInt status
61	if trivial_yield_policy
62	if not_too_unfair
63	field CBool please_schedule
64	else
65	field ThreadQueue queue
66
67
68	function build sem
69	arg_w Sem sem
70	sem status := not_locked
71	if trivial_yield_policy and not_too_unfair
72	sem please_schedule := false
73
74	if pliant_debugging_level>=2
75	function destroy sem
76	arg_w Sem sem
77	if trivial_yield_policy
78	check sem:status=0 or pliant_execution_phase>execution_phase_run "Attempted to destroy a locked semaphore"
79	else
80	check (sem:status=0 and sem:queue:is_empty) or pliant_execution_phase>execution_phase_run "Attempted to destroy a locked semaphore"
81
82
83	if not trivial_yield_policy
84	method sem safe_read_status -> s
85	arg_rw Sem sem ; arg uInt s
86	if busy_wait
87	while true
88	s := atomic_read_and_set sem:status please_retry
89	if s<>please_retry
90	return
91	pentium_counter (var uInt start_low) (var uInt start_high)
92	while { pentium_counter (var uInt lap_low) (var uInt lap_high) ; ( lap_high=start_high or (lap_high .-. start_high)=1 and lap_low<start_low ) and (lap_low .-. start_low)<busy_timeout }
93	while { pentium_counter (var uInt low) (var uInt high) ; ( high=lap_high or (high .-. lap_high)=1 and low<lap_low ) and (low .-. lap_low)<busy_sleep }
94	void # the busy loop
95	s := atomic_read_and_set sem:status please_retry
96	if s<>please_retry
97	return
98	os_yield # timeout
99	else
100	while { s := atomic_read_and_set sem:status please_retry ; s=please_retry }
101	os_yield
102
103	method sem request
104	arg_rw Sem sem
105	if trivial_yield_policy
106	if not_too_unfair and sem:please_schedule and not same_slice
107	os_yield
108	while true
109	var uInt s := atomic_read_and_set sem:status please_retry
110	if s=not_locked
111	sem status := write_locked
112	if not_too_unfair
113	sem please_schedule := false
114	return
115	if s<>please_retry
116	sem status := s
117	os_yield ; set_slice
118	if not_too_unfair
119	sem please_schedule := true
120	else
121	var uInt s := sem safe_read_status
122	if s<>not_locked or not sem:queue:is_empty and not same_slice
123	sem:queue add_current_thread 0 high_cost
124	sem status := s
125	stop_current_thread
126	set_slice
127	s := sem safe_read_status
128	while s<>not_locked
129	sem:queue add_current_thread 0 high_cost
130	sem status := s
131	stop_current_thread
132	set_slice
133	s := sem safe_read_status
134	sem status := write_locked
135
136
137	method sem release
138	arg_rw Sem sem
139	if trivial_yield_policy
140	while (var uInt s := atomic_read_and_set sem:status please_retry ; s=please_retry)
141	os_yield
142	check s=write_locked "Attempted to write realease a not write locked semaphore"
143	sem status := not_locked
144	else
145	var uInt s := sem safe_read_status
146	check s=write_locked "Attempted to write realease a not write locked semaphore"
147	sem:queue restart_some_threads high_cost sem:status not_locked
148
149
150	method sem rd_request
151	arg_rw Sem sem
152	if trivial_yield_policy
153	if not_too_unfair and sem:please_schedule and not same_slice
154	os_yield
155	while true
156	var uInt s := atomic_read_and_set sem:status please_retry
157	if s<>please_retry and s<>write_locked
158	sem status := s+1
159	if not_too_unfair
160	sem please_schedule := false
161	return
162	if s<>please_retry
163	sem status := s
164	os_yield ; set_slice
165	if not_too_unfair
166	sem please_schedule := true
167	else
168	var uInt s := sem safe_read_status
169	if s=write_locked or not sem:queue:is_empty and not same_slice
170	sem:queue add_current_thread 0 1
171	sem status := s
172	stop_current_thread
173	set_slice
174	s := sem safe_read_status
175	while s=write_locked
176	sem:queue add_current_thread 0 1
177	sem status := s
178	stop_current_thread
179	set_slice
180	s := sem safe_read_status
181	sem status := s+1
182
183
184	method sem rd_release
185	arg_rw Sem sem
186	if trivial_yield_policy
187	while (var uInt s := atomic_read_and_set sem:status please_retry ; s=please_retry)
188	os_yield
189	check s>0 and s<>write_locked "Attempted to read realease a not read locked semaphore"
190	sem status := s-1
191	else
192	var uInt s := sem safe_read_status
193	check s>0 and s<>write_locked "Attempted to read realease a not read locked semaphore"
194	if s=1 and not sem:queue:is_empty
195	sem:queue restart_some_threads high_cost sem:status s-1
196	else
197	sem status := s-1
198
199
200	method sem nowait_request -> success
201	arg_rw Sem sem ; arg CBool success
202	if trivial_yield_policy
203	var uInt s := atomic_read_and_set sem:status please_retry
204	if s=not_locked
205	sem status := write_locked
206	success := true
207	else
208	if s<>please_retry
209	sem status := s
210	success := false
211	else
212	var uInt s := sem safe_read_status
213	if s=not_locked and sem:queue:is_empty
214	sem status := write_locked
215	success := true
216	else
217	sem status := s
218	success := false
219
220
221	method sem nowait_rd_request -> success
222	arg_rw Sem sem ; arg CBool success
223	if trivial_yield_policy
224	var uInt s := atomic_read_and_set sem:status please_retry
225	if s<>write_locked and s<>please_retry
226	sem status := s+1
227	success := true
228	else
229	if s<>please_retry
230	sem status := s
231	success := false
232	else
233	var uInt s := sem safe_read_status
234	if s<>write_locked and sem:queue:is_empty
235	sem status := s+1
236	success := true
237	else
238	sem status := s
239	success := false
240
241
242	export Sem '. request' '. release' '. rd_request' '. rd_release' '. nowait_request' '. nowait_rd_request'
243