heap_profile_os_dependent.icl 15.3 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
implementation module heap_profile_os_dependent;

import StdEnv;

::	Header = {
		heap_begin		:: !Int,
		heap_end		:: !Int,
		heap2_begin		:: !Int,
		heap2_end		:: !Int,
		text_begin		:: !Int,	// for PowerPC
		data_begin		:: !Int,
		small_integers	:: !Int,
		characters		:: !Int,
		text_addresses	:: !{#Int}	// for 68k
	};

from files import GetFInfo,NewToolbox,:: Toolbox;

PCorMac pc mac :== mac;
	
FileExists	:: !String -> Bool;
FileExists name = result==0;
{
	(result,_,_)	= GetFInfo name NewToolbox;
}

/* for PowerPC */

	IF_BIG_ENDIAN big little :== big;

	:: Text :== {#Char};

	read_application_name :: !*File -> (!{#Char},!*File);
	read_application_name file = freads file 32;

	read_text_addresses :: !*File -> (!{#Int},!*File);
	read_text_addresses file = ({},file);

	read_application :: !{#Char} !{#Char} Header !Files -> (!Bool,!{#Char},!Text,Header,!Files);
	read_application file_name application_file_name header files
		# application_file_name=replace_file_name_in_path file_name application_file_name;
		# (ok,file,files) = fopen application_file_name FReadData files;
		| not ok
			= abort ("cannot open application file: "+++toString application_file_name);
		# (ok,xcoff_magic,file) = freadi file;
//		| not ok || (xcoff_magic>>16)<>0x01DF
		| not ok || xcoff_magic<>0x4A6F7921
			= abort "not an application file";
//		# (ok1,file) = fseek file 0x94 FSeekSet;
		# (ok1,file) = fseek file 0x54 FSeekSet;
		  (ok2,data_section_size,file) = freadi file;
		  (ok3,data_section_offset,file) = freadi file;
		| not ok1 || not ok2 || not ok3
			= abort "error reading application file";
		# (ok,file) = fseek file data_section_offset FSeekSet;
		  (data,file) = freads file data_section_size;
		| not ok || size data<>data_section_size
			= abort "error reading application file";
//		# (ok1,file) = fseek file 0x6C FSeekSet;
		# (ok1,file) = fseek file 0x38 FSeekSet;
		  (ok2,text_section_size,file) = freadi file;
		  (ok3,text_section_offset,file) = freadi file;
		| not ok1 || not ok2 || not ok3
			= abort "error reading application file";
		# (ok,file) = fseek file text_section_offset FSeekSet;
		  (text,file) = freads file text_section_size;
		| not ok || size text<>text_section_size
			= abort "error reading application file";
		# (ok,files) =fclose file files;
		| not ok
			= abort "error closing application file";
		= (True,data,text,header,files);

	PageNumberOffsetFromEndInFileName:==1;

	get_text_resource_n address header text :== in_text_section address header.text_begin (size text);
	
	in_text_section :: !Int !Int !Int -> Int;
	in_text_section address text_begin size_text
		| address>=text_begin && address<text_begin+size_text
			= 0;
			= -1;

	long_in_text_resource _ /*text_resource_n*/ a header text
		:== text LONG (a-header.text_begin);

	relocate_descriptor descriptor header :== descriptor+header.data_begin;

	is_closure descriptor :== (descriptor bitand 2)==0;

	non_relocated_descriptor_to_data_offset descriptor _/*header*/ _/*data*/ :== descriptor-2;

	relocated_descriptor_to_data_offset descriptor header _ /*data*/ :== descriptor-2-header.data_begin;

	address_to_data_offset a data_begin _ /*data*/ :== a-data_begin;

	non_record_arity :: !Int -> Int;
	non_record_arity arity=arity;
	
	constructor_name data_begin data_offset arity data text :== constructor_name_ data_offset arity data text;

	constructor_name_ :: !Int !Int !{#Char} {#Char} -> (!{#Char},!{#Char});
	constructor_name_ data_offset arity data text
John van Groningen's avatar
John van Groningen committed
104
105
106
107
		# descriptor_max_arity_offset = data_offset + (data WORD (data_offset+2));
		#! string_offset = descriptor_max_arity_offset+12;
		# module_name_offset = data LONG (descriptor_max_arity_offset + 8);
/*
108
109
110
111
		# descriptor_offset=data_offset-(data WORD (data_offset+2));
		  descriptor_arity=data WORD (descriptor_offset-2);
		  string_offset=descriptor_offset+4+(descriptor_arity<<3);
		  module_name_offset = data LONG (descriptor_offset-12);
John van Groningen's avatar
John van Groningen committed
112
113
*/
		  string_length=data LONG string_offset;		  
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
		  module_name_length = data LONG module_name_offset;		  
		= (data % (string_offset+4,string_offset+3+string_length),data % (module_name_offset+4,module_name_offset+3+module_name_length));

	closure_text_offset descriptor _ /*text_resource_n*/ header
		:== descriptor-header.text_begin-4;

	get_closure_arity text_offset _ /*text_resource_n*/ text
		:== text LONG text_offset;

	is_selector arity :== arity<0 && arity>=(-4);

	get_closure_name :: !Int .a .b .c !{#Char} !{#Char} -> .(!{#Char},!{#Char});
	get_closure_name text_offset arity text_resource_n header text data
		# descriptor_toc_offset = text WORD (text_offset - 2);
		| descriptor_toc_offset bitand 3<>0
			= abort "get_closure_name";
		# descriptor_offset = data LONG (descriptor_toc_offset-0x8000);
John van Groningen's avatar
John van Groningen committed
131
132
133
134
135
136

		# descriptor_max_arity_offset = descriptor_offset + (data WORD (descriptor_offset+2));
		#! string_offset = descriptor_max_arity_offset+12;
		# module_name_offset = data LONG (descriptor_max_arity_offset + 8);

/*
137
138
139
		  descriptor_arity=data WORD (descriptor_offset-2);
		  string_offset=descriptor_offset+4+(descriptor_arity<<3);
		  module_name_offset = data LONG (descriptor_offset-12);
John van Groningen's avatar
John van Groningen committed
140
141
*/
		  string_length=(data LONG string_offset);
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
		  module_name_length = data LONG module_name_offset;
		= (data % (string_offset+4,string_offset+3+string_length),data % (module_name_offset+4,module_name_offset+3+module_name_length));

	record_name :: .a !Int !{#Char} .b -> .(!{#Char},!{#Char});
	record_name header data_offset data text
		# string_offset=data LONG (data_offset-4);
		  string_length=(data LONG string_offset);
		  module_name_offset = data LONG (data_offset-8);
		  module_name_length = data LONG module_name_offset;
		= (data % (string_offset+4,string_offset+3+string_length),data % (module_name_offset+4,module_name_offset+3+module_name_length));

	record_type data_offset data text
		# type_string_offset=data_offset+4;
		  end_type_string_offset=find_zero_char type_string_offset data;
		= data % (type_string_offset,dec end_type_string_offset);

				  			  
// end for PowerPC 
/* */

// for 68k
/*
	IF_BIG_ENDIAN big little :== big;

	:: Text :== {!{#Char}};

	read_application_name file = freads file 32;

	read_text_addresses file
		# (text_address_list,file) = read_text_address_list file;
										with {
											read_text_address_list file
												# (ok,text_address,file) = freadi file;
												| not ok
													= abort "error reading text addresses";
												| text_address==0
													= ([],file);
													# (text_addresses,file) = read_text_address_list file;
													= ([text_address:text_addresses],file);
										}
		= ({ i \\ i<-text_address_list},file);

	read_application :: {#Char} {#Char} Header Files -> (!{#Char},!Text,Header,!Files);
	read_application file_name application_file_name header files
		# application_file_name=replace_file_name_in_path file_name application_file_name;
		# (ref_num,t)=HOpenResFile 0 0 application_file_name 3 0;
		| ref_num==(-1)
			= abort "cannot open application file";
		# (code_resource_list,t)=load_code_resources 0 t;
		# (res_error,_)=ResError (CloseResFile ref_num t);
		| res_error<>0
			= abort "error closing application file";
			# code_resources = createArray (length code_resource_list) "";
			  code_resources = fill_array 0 code_resource_list code_resources;
			  		with {
			  			fill_array i [] code_resources = code_resources;
		  				fill_array i [e:l] code_resources = fill_array (inc i) l {code_resources & [i]=e};
		  			}
			  last_code_resource_n = dec (size code_resources);
			  last_code_resource = code_resources.[last_code_resource_n];
			  data_section_size = ((toInt last_code_resource.[0xfc]-0x18)<<16)
		  						 + (toInt last_code_resource.[0xfd]<<8)
		  						 + toInt last_code_resource.[0xfe];
			  data = last_code_resource % (0x101,0x100+data_section_size);
			= (True,data,code_resources,header,files);

	PageNumberOffsetFromEndInFileName:==1;

	load_code_resources n t
		# (h,t)=Get1Resource "CODE" n t;
		| h==0
			= ([],t);
			# (s,t)=GetHandleSize h t;
			  (code_resource,t)=handle_to_string h s t;
			  (code_resources,t)=load_code_resources (inc n) t;
			= ([code_resource:code_resources],t);
 
	handle_to_string :: !Handle !Int !Toolbox -> (!{#Char},!Toolbox);
	handle_to_string handle size t0
		=	(string,t1);
		{
			t1=copy_handle_data_to_string string handle size t0;
			string = createArray size ' ';
		}

	get_text_resource_n address header text :== find_text_resource_n address header.text_addresses text;

	find_text_resource_n address text_addresses text
		= find_text_resource_n 0;
		{
			find_text_resource_n resource_n
				| resource_n>=size text_addresses
					= -1;
				# text_address=text_addresses.[resource_n];
				| address>=text_address && address<text_address+size text.[resource_n]
					= resource_n;
					= find_text_resource_n (inc resource_n);
		}

	long_in_text_resource text_resource_n a header text
		:== text.[text_resource_n] LONG (a-header.text_addresses.[text_resource_n]);

	relocate_descriptor descriptor header :== descriptor;

	is_closure descriptor :== descriptor>=0;

	non_relocated_descriptor_to_data_offset descriptor _/*header*/ data :== size data+descriptor;

	relocated_descriptor_to_data_offset descriptor header data :== size data+descriptor;

	address_to_data_offset a data_begin data :== a-(data_begin-size data);

	non_record_arity arity = arity>>2;

	constructor_name data_begin data_offset arity data text :==	constructor_name_ data_begin data_offset arity data text;
	
	constructor_name_ data_offset arity data text
		# descriptor_offset=data_offset-(arity<<2);
		  string_jump_table_offset=data WORD (descriptor_offset-2);
		= string_from_jump_table_offset string_jump_table_offset text;

	string_from_jump_table_offset string_jump_table_offset text
		# string_offset=(text.[0] WORD (string_jump_table_offset-18))+6;
	  	  string_resource_n=text.[0] WORD (string_jump_table_offset-14);
		  string_length=text.[string_resource_n] LONG (string_offset+4);
		= text.[string_resource_n] % (string_offset+8,string_offset+7+string_length);

	closure_text_offset descriptor text_resource_n header
		:== descriptor-header.text_addresses.[text_resource_n]-2;

	get_closure_arity text_offset text_resource_n text 
		:==text.[text_resource_n] WORD text_offset;
	
	is_selector arity :== arity>=65532;

	(SWORD) string i 
		| w<32768
			= w;
			= w-65536;
		{}{
			w = (string BYTE i<<8) bitor (string BYTE (i+1));
		 }

	get_closure_name text_offset arity text_resource_n header text
		# text_resource=text.[text_resource_n];
		  encoded_string_size=text_resource LONG (text_offset-4);
		  string_size=(encoded_string_size>>2) bitand 63;
		| encoded_string_size==(string_size<<2) bitor (string_size<<10) bitor (string_size<<18) bitor (string_size<<26) bitor 0x00010203
			# string_offset=text_offset-4-((string_size+3) bitand (-4));
			= text_resource % (string_offset,string_offset+string_size-1);
		# encoded_string_size2=text_resource LONG (text_offset-14);
		  string_size2=(encoded_string_size2>>2) bitand 63;
		| (string_size bitand 0xffff)==0 && encoded_string_size2==(string_size2<<2) bitor (string_size2<<10) bitor (string_size2<<18) bitor (string_size2<<26) bitor 0x00010203
			# string_offset=text_offset-14-((string_size2+3) bitand (-4));
			= text_resource % (string_offset,string_offset+string_size2-1);
		# next_text_offset=text_offset+2+text_resource SWORD (text_offset+4);
		| text_resource WORD (text_offset+2)==0x4efa && text_resource WORD next_text_offset==arity
			= get_closure_name2 next_text_offset arity text_resource_n header text;
		# a5_offset=text_resource SWORD (text_offset+4);
		  text0=text.[0];
		  next_resource_offset=(text0 WORD (a5_offset-18))+2;
		  next_resource_n=text0 WORD (a5_offset-14);
		| text_resource WORD (text_offset+2)==0x4eed && a5_offset>=16
			&& text0 WORD (a5_offset-16)==0x3f3c && text0 WORD (a5_offset-12)==0xa9f0
			&& text.[next_resource_n] WORD next_resource_offset==arity
			= get_closure_name2 next_resource_offset arity next_resource_n header text;
			= "Function"+++toString (arity);

	get_closure_name2 text_offset arity text_resource_n header text
		# text_resource=text.[text_resource_n];
		  encoded_string_size=text_resource LONG (text_offset-4);
		  string_size=(encoded_string_size>>2) bitand 63;
		| encoded_string_size==(string_size<<2) bitor (string_size<<10) bitor (string_size<<18) bitor (string_size<<26) bitor 0x00010203
			# string_offset=text_offset-4-((string_size+3) bitand (-4));
			= text_resource % (string_offset,string_offset+string_size-1);
		# encoded_string_size2=text_resource LONG (text_offset-14);
		  string_size2=(encoded_string_size2>>2) bitand 63;
		| (string_size bitand 0xffff)==0 && encoded_string_size2==(string_size2<<2) bitor (string_size2<<10) bitor (string_size2<<18) bitor (string_size2<<26) bitor 0x00010203
			# string_offset=text_offset-14-((string_size2+3) bitand (-4));
			= text_resource % (string_offset,string_offset+string_size2-1);
			= "Function"+++toString (arity);

	record_name header data_offset data text
		# string_jump_table_offset=data WORD (data_offset-2);
		= string_from_jump_table_offset string_jump_table_offset text;

	record_type data_offset data text
		# type_string_offset=data_offset+4;
		  end_type_string_offset=find_zero_char type_string_offset data;
		= data % (type_string_offset,dec end_type_string_offset);

	::	Toolbox:==Int;
	::	Handle:==Int;

	// in resources.icl
	HOpenResFile :: !Int !Int !{#Char} !Int !Toolbox -> (!Int,!Toolbox);
	HOpenResFile vRefNum dirID fileName permission t
	= code (vRefNum=R2W,dirID=L,fileName=S,permission=D1,t=U)(refNum=W,t2=Z){
		instruction 0x1F01			|	move.b	d1,-(sp)
		instruction 0xA81A
	}

	CloseResFile :: !Int !Toolbox -> Toolbox;
	CloseResFile refNum t = code (refNum=W,t=U)(t2=Z){
		instruction	0xA99A
	}

	ResError :: !Toolbox -> (!Int,!Toolbox);
	ResError t = code (t=R2U)(res_error=W,t2=Z){
		instruction 0xA9AF
	}

	Get1Resource :: !{#Char} !Int !Toolbox -> (!Handle,!Toolbox);
	Get1Resource theType index t = code (theType=R4A0,index=D1,t=u)(handle=L,t2=Z){
		instruction 0x2F28 0x0008	|	move.l	8(a0),-(sp)
		instruction 0x3F01			|	move.w	d1,-(sp)
		instruction	0xA81F
	}

	// in memory.icl
	GetHandleSize :: !Handle !Toolbox -> (!Int,!Toolbox);
	GetHandleSize handle t = code (handle=D1,t=U)(result_code=D1,z=Z){
		instruction 0x2041	||	move.l	d1,a0
		instruction 0xA025
		instruction 0x2200	||	move.l	d0,d1	
	}

	copy_handle_data_to_string :: !{#Char} !Handle !Int !Toolbox -> Toolbox;
	copy_handle_data_to_string string handle size t0 = code (string=A0,handle=D2,size=D1,t0=U)(t1=Z){
		instruction	0x2248		||	move.l	a0,a1
		instruction	0x2042		||	move.l	d2,a0
		instruction	0x5089		||	addq.l	#8,a1
		instruction	0x2050		||	move.l	(a0),a0
		instruction	0x2001		||	move.l	d1,d0
		instruction 0xA22E		|| BlockMoveData
	}	
*/
// end for 68k

(BYTE) string i :== toInt (string.[i]);

(WORD) string i :== IF_BIG_ENDIAN
						((string BYTE i<<8) bitor (string BYTE (i+1)))
						((string BYTE i) bitor (string BYTE (i+1) << 8));

(LONG) :: !{#Char} !Int -> Int;
(LONG) string i	= IF_BIG_ENDIAN
					((string BYTE i<<24) bitor (string BYTE (i+1)<<16) bitor (string BYTE (i+2)<<8) bitor (string BYTE (i+3)))
					(((string BYTE i) bitor (string BYTE (i+1) << 8) bitor (string BYTE (i+2) << 16) bitor (string BYTE (i+3) << 24)));

find_zero_char i s
	| s.[i]=='\0'
		= i;
		= find_zero_char (inc i) s;

replace_file_name_in_path path file_name
	= remove_file_name_from_path (size path-1)+++file_name;
{
	remove_file_name_from_path i
		| i<0
			= path;
		| path.[i]==':'
			= path % (0,i);
			= remove_file_name_from_path (i-1);
}