/pliant/language/debug/trace.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	module "/pliant/install/ring2.pli"
17
18	constant execute pliant_debugging_level>0
19	constant debug false
20
21
22
23	# slot
24
25
26	gvar List trace_slots ; gvar FastSem trace_slots_sem
27	gvar CBool trace_memory := false
28
29
30	type TraceSlot
31	if execute
32	field CBool is_active <- false
33	field List handlers
34	field Sem sem
35	field Str name
36
37
38	method ts reset
39	arg_rw TraceSlot ts
40	if execute
41	trace_slots_sem request
42	var Pointer:Arrow c :> trace_slots first
43	while c<>null
44	if c=addressof:ts
45	trace_slots remove c
46	return
47	c :> trace_slots next c
48	trace_slots_sem release
49
50	if execute
51	function destroy ts
52	arg_w TraceSlot ts
53	if pliant_execution_phase>execution_phase_free
54	return
55	ts reset
56
57
58	method ts configure name
59	arg_rw TraceSlot ts ; arg Str name
60	if execute
61	ts reset
62	ts name := name
63	trace_slots_sem request
64	trace_slots append addressof:ts
65	trace_slots_sem release
66
67
68
69	# handler
70
71
72	type TraceHandler
73	void
74
75	method h line message
76	arg_rw TraceHandler h ; arg Str message
77	generic
78
79	method h flush
80	arg_rw TraceHandler h
81	generic
82
83
84	method h bind slot
85	arg_rw TraceHandler h ; arg_rw TraceSlot slot
86	if execute
87	slot:sem request
88	slot:handlers append addressof:h
89	slot is_active := true
90	slot:sem release
91
92	method h unbind slot
93	arg_rw TraceHandler h ; arg_rw TraceSlot slot
94	if execute
95	slot:sem request
96	var Pointer:Arrow c :> slot:handlers first
97	while c<>null
98	if c=addressof:h
99	slot:handlers remove c
100	if slot:handlers:first=null
101	slot:is_active := false
102	slot:sem release
103	return
104	c :> slot:handlers next c
105	slot:sem release
106
107
108	if execute
109	method slot line message
110	arg_rw TraceSlot slot ; arg Str message
111	slot:sem request
112	if debug
113	console "trace "+message+"[lf]"
114	var Pointer:Arrow c :> slot:handlers first
115	while c<>null
116	(c omap TraceHandler) line message
117	(c omap TraceHandler) flush
118	c :> slot:handlers next c
119	slot:sem release
120
121
122
123	# session
124
125
126	type TraceSession
127	if execute
128	field CBool is_active <- false
129	field List:Str lines
130	field Pointer:TraceSlot slot
131	field Int used consumed
132
133	if execute
134	function create s
135	arg_w TraceSession s
136	s slot :> null map TraceSlot
137
138	method s bind slot
139	arg_rw TraceSession s ; arg_rw TraceSlot slot
140	if execute
141	s slot :> slot
142	s is_active := slot is_active
143	s used := memory_current_used
144	s consumed := memory_current_consumed
145
146	if execute
147	method s line message
148	arg_rw TraceSession s ; arg Str message
149	# this method is not thread safe: have one log session per thread
150	s lines += message
151
152	method s flush
153	arg_rw TraceSession s
154	if execute
155	if not (exists s:lines:first)
156	return
157	var Pointer:TraceSlot slot :> s slot
158	slot:sem request
159	if debug
160	var Pointer:Str l :> s:lines first
161	while exists:l
162	console "trace "+l+"[lf]"
163	l :> s:lines next l
164	var Pointer:Arrow c :> slot:handlers first
165	while c<>null
166	if trace_memory
167	(c omap TraceHandler) line "old memory usage: "+(string s:used)+"/"+(string s:consumed)+" ("+(string s:consumed\2^20)+" MB)"
168	var Pointer:Str l :> s:lines first
169	while exists:l
170	(c omap TraceHandler) line l
171	l :> s:lines next l
172	if trace_memory
173	var Int used := memory_current_used
174	var Int consumed := memory_current_consumed
175	(c omap TraceHandler) line "new memory usage: "+string:used+"/"+string:consumed+" ("+(string consumed\2^20)+" MB)"
176	(c omap TraceHandler) flush
177	c :> slot:handlers next c
178	slot:sem release
179	s lines := var List:Str empty_list
180
181	if execute
182	function destroy s
183	arg_w TraceSession s
184	s flush
185
186
187	method s mark -> m
188	arg TraceSession s ; arg Address m
189	if execute
190	m := addressof s:lines:last
191
192	method s rewind m
193	arg_rw TraceSession s ; arg Address m
194	if execute
195	while (addressof s:lines:last)<>m
196	s:lines remove s:lines:last
197
198
199
200	# application interface
201
202
203	constant to_index (the_function '. to string' Universal Str -> Str):generic_index
204
205	if execute
206
207	function to_string data options function -> string
208	arg Universal data ; arg Str options ; arg Function function ; arg Str string
209	indirect
210
211	function trace_single u f slot
212	arg Universal u ; arg Function f ; arg_rw TraceSlot slot
213	slot line (to_string u "raw" f)
214
215	function trace_single u f session
216	arg Universal u ; arg Function f ; arg_rw TraceSession session
217	session line (to_string u "raw" f)
218
219	function trace_first u f s
220	arg Universal u ; arg Function f ; arg_w Str s
221	s := to_string u "raw" f
222
223	function trace_next u f s
224	arg Universal u ; arg Function f ; arg_rw Str s
225	s += to_string u "raw" f
226
227	function trace_last u f s slot
228	arg Universal u ; arg Function f ; arg Str s ; arg_rw TraceSlot slot
229	slot line s+(to_string u "raw" f)
230
231	function trace_last u f s session
232	arg Universal u ; arg Function f ; arg Str s ; arg_rw TraceSession session
233	session line s+(to_string u "raw" f)
234
235
236	meta '. trace' e
237	var Link:Argument slot session
238	if e:size<2
239	return
240	eif (e:0 cast TraceSlot)
241	slot :> e:0 result
242	session :> null map Argument
243	eif (e:0 cast TraceSession)
244	slot :> null map Argument
245	session :> e:0 result
246	else
247	return
248	if (e:0:access .and. access_write)=0
249	return
250	if execute
251	var Link:Argument cond :> argument indirect CBool (argument local Address) 0
252	e suckup e:0
253	if exists:slot
254	e add (instruction (the_function '. is_active' TraceSlot -> CBool) e:0:result cond)
255	else
256	e add (instruction (the_function '. is_active' TraceSession -> CBool) e:0:result cond)
257	var Link:Instruction end :> instruction the_function:'do nothing'
258	e add (instruction (the_function 'jump if not' CBool) cond jump end)
259	var Int base := 1
260	for (var Int i) base e:size-1
261	e:i compile ?
262	var Pointer:Type type :> e:i:result:type:real_data_type
263	e:i cast type ?
264	var Pointer:Function function :> type get_generic_method to_index
265	if addressof:function=null or addressof:function=addressof:(the_function '. to string' Universal Str -> Str)
266	return
267	if execute
268	e suckup e:i
269	if e:size-base=1
270	if exists:slot
271	e add (instruction (the_function trace_single Universal Function TraceSlot) e:i:result (argument mapped_constant Function function) slot)
272	else
273	e add (instruction (the_function trace_single Universal Function TraceSession) e:i:result (argument mapped_constant Function function) session)
274	eif i=base
275	var Link:Argument buf :> argument local Str
276	e add (instruction (the_function trace_first Universal Function Str) e:i:result (argument mapped_constant Function function) buf)
277	eif i=e:size-1
278	if exists:slot
279	e add (instruction (the_function trace_last Universal Function Str TraceSlot) e:i:result (argument mapped_constant Function function) buf slot)
280	else
281	e add (instruction (the_function trace_last Universal Function Str TraceSession) e:i:result (argument mapped_constant Function function) buf session)
282	else
283	e add (instruction (the_function trace_next Universal Function Str) e:i:result (argument mapped_constant Function function) buf)
284	if execute
285	e add end
286	e set_void_result
287
288
289	export trace_slots trace_slots_sem trace_memory
290	export TraceSlot '. configure' '. reset' '. name'
291	export TraceHandler '. bind' '. unbind' '. line' '. flush'
292	export TraceSession '. bind' '. flush' '. mark' '. rewind'
293	export '. trace'
294