/pliant/language/schedule/threads_engine.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/"
17	module "/pliant/install/ring2.pli"
18	module "pentium.pli"
19
20	constant has_user_field true
21
22
23	if os_api="linux"
24	constant pliant_suspend_signal os_SIGUSR1
25	constant thread_trace false
26	public
27	constant stack_size 1024*2^10 # must match start.s
28	gvar Int stack_base
29
30
31	type ThreadHeader
32	field Address variables_context
33	field Int language_index
34	if has_user_field
35	field Str user
36	if os_api="linux"
37	field Int pid
38	eif os_api="os2"
39	field Int tid
40	eif os_api="posix"
41	field Int id
42	eif os_api="win32"
43	field Int handle
44	field Int priority
45	field Int restart_cost
46	field Pointer:ThreadHeader next
47	field DelayedAction action
48	field Address address # used by 'execute'
49	field Pointer:ThreadHeader list_next list_previous
50	field FastSem action_sem
51	field Pointer:ActionRecord top_action
52	field Pointer:ErrorRecord top_error
53	field ErrorRecord bottom_error
54	if processor_is_pentium
55	field uInt processor_counter_low processor_counter_high
56
57	if os_api="linux"
58	check ThreadHeader:size<=256 # must match start.s
59
60	export ThreadHeader '. variables_context' '. language_index' '. address'
61	export '. list_next' '. action_sem' '. top_action'
62	if has_user_field
63	export '. user'
64	if os_api="linux"
65	export '. pid'
66	eif os_api="os2"
67	export '. tid'
68	if processor_is_pentium
69	export '. processor_counter_low' '. processor_counter_high'
70
71
72	method h setup
73	arg_rw ThreadHeader h
74	h language_index := 0
75	if has_user_field
76	Str build_instance (addressof h:user)
77	h top_action :> null map ActionRecord
78	h:bottom_error id := error_id_noerror
79	h:bottom_error filter := error_filter_none
80	h:bottom_error next :> null map ErrorRecord
81	h top_error :> h bottom_error
82
83
84	public
85	gvar FastSem thread_list_sem
86	gvar ThreadHeader thread_list_pivot
87	thread_list_pivot list_next :> thread_list_pivot ; thread_list_pivot list_previous :> thread_list_pivot
88
89	function thread_insert_header h
90	arg_rw ThreadHeader h
91	thread_list_sem request
92	h list_next :> thread_list_pivot list_next
93	h list_previous :> thread_list_pivot
94	thread_list_pivot:list_next list_previous :> h
95	thread_list_pivot list_next :> h
96	thread_list_sem release
97
98	function thread_remove_header h
99	arg_rw ThreadHeader h
100	thread_list_sem request
101	h:list_previous list_next :> h list_next
102	h:list_next list_previous :> h list_previous
103	thread_list_sem release
104
105
106
107	#  starting and stopping threads
108
109
110	if os_api="linux"
111
112	if false
113
114	function stop_current_thread
115	os_kill current_thread_header:pid os_SIGSTOP
116
117	function restart_thread h
118	arg ThreadHeader h
119	os_kill h:pid os_SIGCONT
120
121	else
122
123	function stop_current_thread
124	os_sigsuspend 0 0 .not. (2^(pliant_suspend_signal-1) .or. 2^(os_SIGINT-1) .or. 2^(os_SIGTERM-1) .or. 2^(os_SIGKILL-1))
125	os_sigsetmask 2^(pliant_suspend_signal-1)
126
127	function restart_thread h
128	arg ThreadHeader h
129	os_kill h:pid pliant_suspend_signal
130
131	function exception_handler3 num
132	arg Int num
133	external_calling_convention
134	gvar os_sigaction sa3
135	sa3 sa_handler := (the_function exception_handler3 Int) executable
136	entry_root addressof:(the_function exception_handler3 Int)
137	function record_exception_handler3 parameter filehandle
138	arg Address parameter ; arg Int filehandle
139	if (os_sigaction pliant_suspend_signal sa3 (null map os_sigaction))<>0
140	error error_id_os "Failed to install Linux pliant_suspend_signal exception handler"
141	record_exception_handler3 null 0
142	gvar DelayedAction da3
143	da3 function :> the_function record_exception_handler3 Address Int
144	pliant_restore_actions append addressof:da3
145
146	eif os_api="posix"
147
148	function pthread_self -> handle
149	arg Int handle
150	external os_libpthread_filename "pthread_self"
151
152	function pthread_kill handle signal -> err
153	arg Int handle signal err
154	external os_libpthread_filename "pthread_kill"
155
156	function stop_current_thread
157	pthread_kill pthread_self os_SIGSTOP
158
159	function restart_thread h
160	arg ThreadHeader h
161	pthread_kill h:id os_SIGCONT
162
163	eif os_api="win32"
164
165	gvar Int tls
166
167	function current_thread_header -> h
168	arg_RW ThreadHeader h
169	h :> os_TlsGetValue:tls map ThreadHeader
170
171	function stop_current_thread
172	var Pointer:ThreadHeader h :> current_thread_header
173	while h:handle=(-1)
174	os_yield
175	os_SuspendThread h:handle
176
177	function restart_thread h
178	arg ThreadHeader h
179	while (os_ResumeThread h:handle)<=0
180	os_yield
181
182	eif os_api="os2"
183
184	function stop_current_thread
185	os_DosSuspendThread current_thread_header:tid
186
187	function restart_thread h
188	arg ThreadHeader h
189	while (os_DosResumeThread h:tid)=ERROR_NOT_FROZEN
190	os_yield
191
192
193
194	#  allocating thread stacks
195
196	if os_api="linux"
197
198	public
199	gvar Int thread_stacks_count := 1
200	gvar FastSem threads_sem
201	gvar Pointer:ThreadHeader first_zombie :> null map ThreadHeader
202	gvar Pointer:ThreadHeader first_available :> null map ThreadHeader
203
204	gvar Pointer:ThreadHeader recycling_first :> null map ThreadHeader
205	gvar FastSem recycling_sem
206
207	function record_zombie h
208	arg_rw ThreadHeader h
209	threads_sem request
210	h next :> first_zombie ; first_zombie :> h
211	threads_sem release
212
213	function terminate_zombies
214	if addressof:first_zombie=null
215	return
216	var Pointer:ThreadHeader lost :> null map ThreadHeader
217	threads_sem request
218	while addressof:first_zombie<>null
219	var Pointer:ThreadHeader h :> first_zombie ; first_zombie :> h next
220	threads_sem release
221	var Int pid := os_waitpid h:pid (null map Int) 80000000h # waits for a cloned process
222	threads_sem request
223	if pid=h:pid
224	h pid := 0
225	h next :> first_available ; first_available :> h
226	else
227	h next :> lost ; lost :> h
228	while addressof:lost<>null
229	h :> lost ; lost :> h next
230	h next :> first_zombie ; first_zombie :> h
231	threads_sem release
232
233	function allocate_stack -> h
234	arg_RW ThreadHeader h
235	threads_sem request
236	if addressof:first_available<>null
237	h :> first_available ; first_available :> h next
238	threads_sem release
239	else
240	var Address bottom := cast stack_base.-.thread_stacks_count*stack_size Address
241	if (cast bottom uInt)<(cast memory_base_address uInt)
242	error_notify_fatal error_id_memory_starvation "Out of memory pages for thread stacks"
243	memory_limit_address := bottom
244	thread_stacks_count := thread_stacks_count+1
245	threads_sem release
246	var Address got := os_mmap bottom stack_size os_PROT_READ+os_PROT_WRITE os_MAP_PRIVATE+os_MAP_ANONYMOUS+os_MAP_FIXED+os_MAP_GROWSDOWN -1 0
247	if got<>(cast -1 Address)
248	h :> ((bottom translate Byte stack_size) translate ThreadHeader -1) map ThreadHeader
249	h pid := 0
250	else
251	h :> null map ThreadHeader
252
253	function free_stack h
254	arg_rw ThreadHeader h
255	threads_sem request
256	h pid := 0
257	h next :> first_available ; first_available :> h
258	threads_sem release
259
260	export record_zombie terminate_zombies allocate_stack free_stack
261
262	eif os_api="posix" or os_api="win32" or os_api="os2"
263
264	gvar FastSem threads_sem
265	gvar Pointer:ThreadHeader first_zombie :> null map ThreadHeader
266
267	function record_zombie h
268	arg_rw ThreadHeader h
269	threads_sem request
270	h next :> first_zombie ; first_zombie :> h
271	threads_sem release
272
273	function terminate_zombies
274	if addressof:first_zombie=null
275	return
276	threads_sem request
277	while addressof:first_zombie<>null
278	var Pointer:ThreadHeader h :> first_zombie ; first_zombie :> h next
279	if os_api="win32"
280	threads_sem release
281	while h:handle=(-1)
282	os_yield
283	os_CloseHandle h:handle
284	threads_sem request
285	entry_unlock addressof:h
286	threads_sem release
287
288
289
290	#  running a new thread
291
292
293	gvar Int current_running_threads := 1
294	gvar Int maximum_running_threads := 1
295
296	function execute1 a f
297	arg Address a ; arg Function f
298	indirect
299
300	if os_api="linux"
301
302	function current_thread_header -> h
303	arg_RW ThreadHeader h
304	has_side_effects
305	var Int esp := i386_register i386_esp
306	var Int stack_bottom := esp .and. .not. (cast stack_size-1 Int)
307	h :> (cast stack_bottom .+. (stack_size-ThreadHeader:size) Address) map ThreadHeader
308
309	function set_first_thread_info p fh
310	arg Address p ; arg Int fh
311	var Int esp := i386_register i386_esp
312	stack_base := esp .and. .not. (cast stack_size-1 Int)
313	var Pointer:ThreadHeader h :> current_thread_header
314	h setup
315	h pid := os_getpid
316	#
317	thread_stacks_count := 1
318	first_zombie :> null map ThreadHeader
319	first_available :> null map ThreadHeader
320	recycling_first :> null map ThreadHeader
321	set_first_thread_info null 0
322	gvar DelayedAction da1
323	da1 function :> the_function set_first_thread_info Address Int
324	pliant_restore_actions insert_before pliant_restore_actions:first addressof:da1
325
326	gcc_off
327
328	function run_thread action -> success
329	arg DelayedAction action ; arg CBool success
330	if thread_trace
331	console "run "+action:function:position+"[lf]"
332	recycling_sem request
333	if exists:recycling_first
334	var Pointer:ThreadHeader h :> recycling_first
335	recycling_first :> h next
336	recycling_sem release
337	var Pointer:ThreadHeader cth :> current_thread_header
338	h variables_context := cth variables_context
339	h language_index := cth language_index
340	if has_user_field
341	h user := cth user
342	h action := action
343	restart_thread h
344	return true
345	recycling_sem release
346	terminate_zombies
347	atomic_add current_running_threads 1
348	maximum_running_threads := max maximum_running_threads current_running_threads
349	var Pointer:ThreadHeader h :> allocate_stack
350	if not exists:h
351	atomic_add current_running_threads -1
352	return false
353	h setup
354	var Pointer:ThreadHeader cth :> current_thread_header
355	h variables_context := cth variables_context
356	h language_index := cth language_index
357	if has_user_field
358	h user := cth user
359	DelayedAction build_instance (addressof h:action)
360	ErrorRecord build_instance (addressof h:bottom_error)
361	h action := action
362	var Int pid := os_clone 8F00h (addressof:h translate Byte -256)
363	if pid=0
364	h :> current_thread_header
365	h pid := os_getpid
366	os_sigsetmask 2^(pliant_suspend_signal-1)
367	thread_insert_header h
368	execute1 h:action:parameter h:action:function
369	error_report
370	while pliant_execution_phase<=execution_phase_run and (exists h:action:function)
371	DelayedAction destroy_instance (addressof h:action)
372	DelayedAction build_instance (addressof h:action)
373	ActionRecord build_instance addressof:(var ActionRecord ar)
374	action_push_record (var ActionRecord ar) "recycling"
375	recycling_sem request
376	h next :> recycling_first
377	recycling_first :> h
378	recycling_sem release
379	stop_current_thread
380	action_pull_record ar
381	ActionRecord destroy_instance addressof:ar
382	if (exists h:action:function)
383	execute1 h:action:parameter h:action:function
384	error_report
385	thread_remove_header h
386	ErrorRecord destroy_instance (addressof h:bottom_error)
387	record_zombie h
388	atomic_add current_running_threads -1
389	os_exit 0
390	eif pid=(-1)
391	DelayedAction destroy_instance (addressof h:action)
392	free_stack h
393	atomic_add current_running_threads -1
394	return false
395	else
396	return true
397
398	function threads_shrink
399	recycling_sem request
400	while exists:recycling_first
401	var Pointer:ThreadHeader h :> recycling_first
402	recycling_first :> h next
403	restart_thread h
404	recycling_sem release
405
406	eif os_api="posix"
407
408	function pthread_key_create handle destructor -> err
409	arg_w Int handle ; arg Address destructor ; arg Int err
410	external os_libpthread_filename "pthread_key_create"
411
412	function pthread_setspecific handle value -> err
413	arg Int handle ; arg Address value ; arg Int err
414	external os_libpthread_filename "pthread_setspecific"
415
416	function pthread_getspecific handle -> value
417	arg Int handle ; arg Address value
418	external os_libpthread_filename "pthread_getspecific"
419
420	function pthread_create handle attr routine arg -> err
421	arg_w Int handle ; arg Address attr routine arg ; arg Int err
422	external os_libpthread_filename "pthread_create"
423
424	gvar Int key
425	gvar ThreadHeader first_thread_header
426
427	function set_first_thread_info p fh
428	arg Address p ; arg Int fh
429	first_thread_header id := pthread_self
430	pthread_key_create key null
431	pthread_setspecific key addressof:first_thread_header
432	set_first_thread_info null 0
433	gvar DelayedAction da1
434	da1 function :> the_function set_first_thread_info Address Int
435	pliant_restore_actions insert_before pliant_restore_actions:first addressof:da1
436
437	function current_thread_header -> h
438	arg_RW ThreadHeader h
439	h :> pthread_getspecific:key map ThreadHeader
440
441	function thread_execute h
442	arg_rw ThreadHeader h
443	external_calling_convention
444	pthread_setspecific key addressof:h
445	h id := pthread_self
446	thread_insert_header h
447	execute1 h:action:parameter h:action:function
448	thread_remove_header h
449	error_report
450	h:bottom_error context := null
451	h:action parameter := null
452	record_zombie h
453	atomic_add current_running_threads -1
454
455	gcc_off
456
457	function run_thread action -> success
458	arg DelayedAction action ; arg CBool success
459	terminate_zombies
460	atomic_add current_running_threads 1
461	maximum_running_threads := max maximum_running_threads current_running_threads
462	var Pointer:ThreadHeader h :> new ThreadHeader ; entry_lock addressof:h
463	h setup
464	var Pointer:ThreadHeader cth :> current_thread_header
465	h variables_context := cth variables_context
466	h language_index := cth language_index
467	if has_user_field
468	h user := cth user
469	h action := action
470	success := (pthread_create (var Int handle) null (the_function thread_execute ThreadHeader):executable addressof:h)=0
471	if not success
472	atomic_add current_running_threads -1
473	entry_unlock addressof:h
474
475	function threads_shrink
476	void
477
478	eif os_api="win32"
479
480	gvar ThreadHeader first_thread_header
481
482	if pliant_debugging_level>=1
483	module "/pliant/language/debug/report.pli"
484
485	function set_first_thread_info p fh
486	arg Address p ; arg Int fh
487	os_DuplicateHandle os_GetCurrentProcess os_GetCurrentThread os_GetCurrentProcess first_thread_header:handle 0 false DUPLICATE_SAME_ACCESS
488	if pliant_debugging_level>=1
489	'first thread handle' := first_thread_header handle
490	tls := os_TlsAlloc
491	os_TlsSetValue tls addressof:first_thread_header
492	set_first_thread_info null 0
493	gvar DelayedAction da1
494	da1 function :> the_function set_first_thread_info Address Int
495	pliant_restore_actions insert_before pliant_restore_actions:first addressof:da1
496
497	function thread_execute h
498	arg_rw ThreadHeader h
499	external_calling_convention
500	os_TlsSetValue tls addressof:h
501	thread_insert_header h
502	execute1 h:action:parameter h:action:function
503	thread_remove_header h
504	error_report
505	h:bottom_error context := null
506	h:action parameter := null
507	record_zombie h
508	atomic_add current_running_threads -1
509
510	function run_thread action -> success
511	arg DelayedAction action ; arg CBool success
512	terminate_zombies
513	atomic_add current_running_threads 1
514	maximum_running_threads := max maximum_running_threads current_running_threads
515	var Pointer:ThreadHeader h :> new ThreadHeader ; entry_lock addressof:h
516	h setup
517	var Pointer:ThreadHeader cth :> current_thread_header
518	h variables_context := cth variables_context
519	h language_index := cth language_index
520	if has_user_field
521	h user := cth user
522	h action := action
523	h handle := -1
524	h handle := os_CreateThread null 0 (the_function thread_execute ThreadHeader):executable addressof:h 0 (var Int tid)
525	success := h:handle<>0
526	if not success
527	atomic_add current_running_threads -1
528	entry_unlock addressof:h
529
530	function threads_shrink
531	void
532
533	eif os_api="os2"
534
535	public
536	gvar Int stack_size := 1024*2^10
537	gvar ThreadHeader first_thread_header
538	gvar Address thread_mem
539
540	function set_first_thread_info p fh
541	arg Address p ; arg Int fh
542	os_DosGetInfoBlocks (var Pointer:os_TIB tib) (var Pointer:os_PIB pib)
543	first_thread_header tid := tib:tib2:tid
544	os_DosAllocThreadLocalMemory 1 thread_mem
545	thread_mem map Address := addressof first_thread_header
546	set_first_thread_info null 0
547	gvar DelayedAction da1
548	da1 function :> the_function set_first_thread_info Address Int
549	pliant_restore_actions insert_before pliant_restore_actions:first addressof:da1
550
551	function current_thread_header -> h
552	arg_RW ThreadHeader h
553	h :> thread_mem map Pointer:ThreadHeader
554
555	if pliant_debugging_level>=1
556	module "/pliant/language/debug/report.pli"
557
558	function thread_execute h
559	arg_rw ThreadHeader h
560	external_calling_convention
561	if pliant_debugging_level>=1
562	var os_ExceptionHandler eh
563	eh previous := null
564	eh executable := (the_function 'os2 exception routine' os_ExceptionReport os_ExceptionHandler os_ExceptionContext Address -> Int) executable
565	os_DosSetExceptionHandler eh
566	os_DosGetInfoBlocks (var Pointer:os_TIB tib) (var Pointer:os_PIB pib)
567	h tid := tib:tib2:tid
568	thread_mem map Address := addressof h
569	thread_insert_header h
570	execute1 h:action:parameter h:action:function
571	thread_remove_header h
572	error_report
573	h:bottom_error context := null
574	h:action parameter := null
575	record_zombie h
576	atomic_add current_running_threads -1
577	if pliant_debugging_level>=1
578	os_DosUnsetExceptionHandler eh
579
580	function run_thread action -> success
581	arg DelayedAction action ; arg CBool success
582	terminate_zombies
583	atomic_add current_running_threads 1
584	maximum_running_threads := max maximum_running_threads current_running_threads
585	var Pointer:ThreadHeader h :> new ThreadHeader ; entry_lock addressof:h
586	h setup
587	var Pointer:ThreadHeader cth :> current_thread_header
588	h variables_context := cth variables_context
589	h language_index := cth language_index
590	if has_user_field
591	h user := cth user
592	h action := action
593	success := (os_DosCreateThread (var Int tid) (the_function thread_execute ThreadHeader):executable addressof:h 0 stack_size)=0
594	if not success
595	atomic_add current_running_threads -1
596	entry_unlock addressof:h
597
598	function threads_shrink
599	void
600
601	if os_api="posix" or os_api="win32" or os_api="os2"
602	if addressof:current_thread_header<>addressof:first_thread_header
603	error error_id_os "Threads interface seems to be buggy under "+os_api # +" "+'convert to string':(cast addressof:current_thread_header Int)+" "+'convert to string':(cast addressof:first_thread_header Int)
604
605
606	export run_thread threads_shrink current_thread_header
607	export current_running_threads maximum_running_threads
608
609
610	if os_api="linux"
611
612	public
613	gvar Address memory_semaphore_address
614
615	if pliant_c_debugging_level>=2
616	function nolock
617	void
618	entry_root addressof:(the_function nolock)
619
620	function back_to_single_thread
621	var Int me := os_getpid
622	for (var Int i) thread_stacks_count-1 0 step -1
623	var Int bottom := stack_base.-.i*stack_size
624	var Pointer:ThreadHeader h :> (cast bottom .+. (stack_size-ThreadHeader:size) Address) map ThreadHeader
625	if h:pid<>me and h:pid>0
626	os_kill h:pid os_SIGKILL
627	memory_semaphore_address map Int := 0
628	if pliant_c_debugging_level>=2
629	pliant_entry_lock_hook := the_function:nolock executable ; pliant_entry_unlock_hook := the_function:nolock executable
630
631	export back_to_single_thread
632
633	if pliant_debugging_level=0
634
635	gvar CBool first_time := true
636
637	function error_fatal_hook id message
638	arg Int id ; arg Str message
639	console message ; console "[lf]"
640	if first_time
641	first_time := false
642	back_to_single_thread
643	os_exit (min id (addressof:error_id_user map Int))
644
645	entry_root addressof:(the_function error_fatal_hook Int Str)
646	pliant_error_fatal_hook := (the_function error_fatal_hook Int Str) executable
647
648	function exception_handler2 num mark1 mark2 mark3 mark4 edi esi ebp esp ebx edx ecx eax drop1 drop2 eip
649	arg Int num mark1 mark2 mark3 mark4 edi esi ebp esp ebx edx ecx eax drop1 drop2 eip
650	external_calling_convention
651	if first_time
652	first_time := false
653	back_to_single_thread
654	console "exception " ; console 'convert to string':num ; console "[lf]"
655	os_exit 4
656
657	gvar os_sigaction sa
658	sa sa_handler := (the_function exception_handler2 Int Int Int Int Int Int Int Int Int Int Int Int Int Int Int Int) executable
659	entry_root addressof:(the_function exception_handler2 Int Int Int Int Int Int Int Int Int Int Int Int Int Int Int Int)
660
661	function record_exception_handler parameter filehandle
662	arg Address parameter ; arg Int filehandle
663	# catching bugs
664	if (os_sigaction os_SIGSEGV sa (null map os_sigaction))<>0
665	error error_id_os "Failed to install Linux SIGSEGV exception handler"
666	if (os_sigaction os_SIGBUS sa (null map os_sigaction))<>0
667	error error_id_os "Failed to install Linux SIGBUS exception handler"
668	if (os_sigaction os_SIGFPE sa (null map os_sigaction))<>0
669	error error_id_os "Failed to install Linux SIGFPE exception handler"
670	# catching terminal close
671	if (os_sigaction os_SIGHUP sa (null map os_sigaction))<>0
672	error error_id_os "Failed to install Linux SIGHUP exception handler"
673	# catching Ctrl+C
674	if (os_sigaction os_SIGINT sa (null map os_sigaction))<>0
675	error error_id_os "Failed to install Linux SIGINT exception handler"
676	# catching kill
677	if (os_sigaction os_SIGTERM sa (null map os_sigaction))<>0
678	error error_id_os "Failed to install Linux SIGTERM exception handler"
679	record_exception_handler null 0
680	gvar DelayedAction da
681	da function :> the_function record_exception_handler Address Int
682	pliant_restore_actions append addressof:da
683
684
685
686	#  multithreaded errors handling
687
688
689	function mt_action_push_record ar action
690	arg_w ActionRecord ar ; arg Str action
691	if (addressof ar:next)<>(cast -1 Address)
692	error_notify_fatal error_id_unexpected "Action record pushed twice"
693	if pliant_verbose_level_variable>=2
694	console "[cr]"+(action 0 78)+" "
695	ar action := action
696	var Pointer:ThreadHeader h :> current_thread_header
697	h:action_sem request
698	ar next :> h top_action
699	h top_action :> ar
700	h:action_sem release
701
702	function mt_action_pull_record ar
703	arg_rw ActionRecord ar
704	if (addressof ar:next)<>(cast -1 Address)
705	var Pointer:ThreadHeader h :> current_thread_header
706	while true
707	h:action_sem request
708	var Pointer:ActionRecord top :> h top_action
709	if not exists:top
710	error_notify_fatal error_id_unexpected "Wrong action record pulled ("+ar:action+")"
711	h top_action :> top next
712	h:action_sem release
713	top next :> (cast -1 Address) map ActionRecord
714	if addressof:top=addressof:ar
715	return
716
717	function mt_action_top_record -> a
718	arg_RW ActionRecord a
719	a :> current_thread_header top_action
720
721
722	function mt_error_push_record e filter
723	arg_w ErrorRecord e ; arg ErrorID filter
724	if (addressof e:next)<>(cast -1 Address)
725	error_notify_fatal error_id_unexpected "Error record pushed twice"
726	e id := error_id_noerror
727	e filter := filter
728	var Pointer:ThreadHeader h :> current_thread_header
729	e next :> h top_error
730	h top_error :> e
731
732	function mt_error_pull_record e
733	arg_rw ErrorRecord e
734	var Pointer:ThreadHeader h :> current_thread_header
735	if (addressof h:top_error)<>addressof:e
736	error_notify_fatal error_id_corrupted "Wrong error record pulled"
737	error_propagate e e:next
738	h top_error :> e next
739	error_report
740	e next :> (cast -1 Address) map ErrorRecord
741
742	function mt_error_top_record -> e
743	arg_RW ErrorRecord e
744	e :> current_thread_header top_error
745
746	export mt_action_push_record mt_action_pull_record
747
748
749	entry_root addressof:(the_function mt_action_push_record ActionRecord Str)
750	entry_root addressof:(the_function mt_action_pull_record ActionRecord)
751	entry_root addressof:(the_function mt_action_top_record -> ActionRecord)
752	entry_root addressof:(the_function mt_error_push_record ErrorRecord ErrorID)
753	entry_root addressof:(the_function mt_error_pull_record ErrorRecord)
754	entry_root addressof:(the_function mt_error_top_record -> ErrorRecord)
755	function activate_mt_hooks
756	var Pointer:ThreadHeader h :> current_thread_header
757	h top_action :> action_top_record
758	h top_error :> error_top_record
759	pliant_action_push_record_hook := (the_function mt_action_push_record ActionRecord Str) executable
760	pliant_action_pull_record_hook := (the_function mt_action_pull_record ActionRecord) executable
761	pliant_action_top_record_hook := (the_function mt_action_top_record -> ActionRecord) executable
762	pliant_error_push_record_hook := (the_function mt_error_push_record ErrorRecord ErrorID) executable
763	pliant_error_pull_record_hook := (the_function mt_error_pull_record ErrorRecord) executable
764	pliant_error_top_record_hook := (the_function mt_error_top_record -> ErrorRecord) executable
765	activate_mt_hooks
766
767	function restore_mt_hooks p fh
768	arg Address p ; arg Int fh
769	var Pointer:ThreadHeader h :> current_thread_header
770	current_running_threads := 1
771	thread_list_pivot list_next :> thread_list_pivot ; thread_list_pivot list_previous :> thread_list_pivot
772	thread_insert_header h
773	gvar DelayedAction restore
774	restore function :> the_function restore_mt_hooks Address Int
775	pliant_restore_actions insert_after pliant_restore_actions:first addressof:restore
776
777	function do_nothing drop
778	arg Address drop
779
780	function shutdown_threads p
781	arg Address p
782	if os_api="linux"
783	while { recycling_sem request ; exists recycling_first }
784	var Pointer:ThreadHeader h :> recycling_first
785	recycling_first :> h next
786	recycling_sem release
787	h:action function :> the_function do_nothing Address
788	restart_thread h
789	os_yield
790	recycling_sem release
791	terminate_zombies
792	gvar DelayedAction shutdown
793	shutdown function :> the_function shutdown_threads Address
794	pliant_shutdown_actions append addressof:shutdown
795
796
797
798	#  handling waiting threads queues
799
800
801	type ThreadQueue
802	field Pointer:ThreadHeader first
803
804	function build  q
805	arg_w ThreadQueue q
806	q first :> null map ThreadHeader
807
808	method q is_empty -> empty
809	arg ThreadQueue q ; arg CBool empty
810	empty := (addressof q:first)=null
811
812
813	method queue add_current_thread priority restart_cost
814	arg_rw ThreadQueue queue ; arg Int priority ; arg Int restart_cost
815	var (Pointer Pointer:ThreadHeader) q :>> queue first
816	while addressof:q<>null and q:priority>=priority
817	q :>> q next
818	var Pointer:ThreadHeader h :> current_thread_header
819	h priority := priority
820	h restart_cost := restart_cost
821	h next :> q ; q :> h
822
823	method queue restart_some_threads quantity
824	arg_rw ThreadQueue queue ; arg Int quantity
825	var Pointer:ThreadHeader h :> queue first
826	if addressof:h<>null
827	var Int q := h restart_cost
828	var Pointer:ThreadHeader stop :> h next
829	restart_thread h
830	while addressof:stop<>null and q+stop:restart_cost<=quantity
831	h :> stop
832	q += h restart_cost
833	stop :> h next
834	restart_thread h
835	queue first :> stop
836
837	if true
838	method queue restart_some_threads quantity variable value
839	arg_rw ThreadQueue queue ; arg Int quantity ; arg_rw uInt variable ; arg uInt value
840	if true
841	var Pointer:ThreadHeader start :> queue first
842	if addressof:start<>null
843	var Int q := start restart_cost
844	var Pointer:ThreadHeader stop :> start next
845	while addressof:stop<>null and q+stop:restart_cost<=quantity
846	q += stop restart_cost
847	stop :> stop next
848	queue first :> stop
849	variable := value
850	while addressof:start<>addressof:stop
851	var Pointer:ThreadHeader h :> start
852	start :> h next
853	restart_thread h
854	else
855	variable := value
856	else
857	queue restart_some_threads quantity
858	variable := value
859
860
861	export stop_current_thread restart_thread
862	export ThreadQueue '. is_empty' '. add_current_thread' '. restart_some_threads'
863
864