Atlas - PROHST.PAS
Home / ext / JunkDrawer / DOS / BuildTools / v2.0 Lines: 1 | Size: 11520 bytes [Download] [Show on GitHub] [Search similar files] [Raw] [Raw (proxy)][FILE BEGIN]1PROGRAM prohst(input,output); 2{$debug- $line- $symtab+} 3 4{**********************************************************************} 5{* *} 6{* prohst *} 7{* *} 8{* This program produces a histogram from the profile file produced *} 9{* by the MS-DOS profile utility. It optionally reads the map file *} 10{* generated when the program being profiled was linked, and writes *} 11{* either the module address or, if available, the line number as *} 12{* a prefix to the line of the graph which describes a particular *} 13{* bucket. *} 14{* *} 15{* After using filbm (derived from the Pascal and Fortran front end *} 16{* command scanner) to parse its parameters, prohst opens the map *} 17{* file if specified, searches for the heading line, and then reads *} 18{* the lines giving the names and positions of the modules. It builds *} 19{* a linked list of module names and start addresses. *} 20{* *} 21{* It then reads the bucket file header and and bucket array elements *} 22{* into a variable created on the heap. It simultaneously calculates *} 23{* a normalization factor. It writes the profile listing header and *} 24{* starts to write the profile lines. For each bucket, the address *} 25{* is calculated. The first entry in the address/name linked list *} 26{* is the lowest addressed module. This is initially the 'current' *} 27{* module. The bucket address is compared with the current module *} 28{* address. When it becomes the greater, the module name is written *} 29{* to the listing and the next entry in the address/name list becomes *} 30{* the current module. If line numbers are available, the bucket *} 31{* address is also compared to the current line/address. This is *} 32{* read and calculated directly from the file. Since there may be *} 33{* more than one line per bucket, several entries may be read until *} 34{* the addresses compare within the span of addresses encompassed by *} 35{* a bucket (its 'width'). Note that the idiosyncracies of Pascal i/o *} 36{* make it necessary to continually check for the end of the map file *} 37{* and the complexity of this code is mainly due to an attempt to *} 38{* make it reasonably resilient to changes in the format of the map *} 39{* file. *} 40{* *} 41{**********************************************************************} 42 43 44CONST 45 max_file = 32; 46 47 48TYPE 49 filenam = LSTRING (max_file); 50 sets = SET OF 0..31; 51 address_pointer = ^address_record; 52 address_record = RECORD 53 next: address_pointer; 54 name: STRING (15); 55 address: WORD; 56 END; 57 58 59 60 61 62VAR 63 64 i: INTEGER; 65 bucket: FILE OF WORD; 66 hist: TEXT; 67 map: TEXT; 68 69 first_address, 70 this_address: address_pointer; 71 current_base: WORD; 72 bucket_name, 73 hist_name, 74 map_name: filenam; 75 76 switches: sets; 77 78 line: LSTRING (100); 79 80 map_avail: BOOLEAN; 81 line_nos_avail: BOOLEAN; 82 83 norm: REAL; 84 per_cent: INTEGER; 85 real_bucket, 86 norm_bucket: REAL; 87 cum_per_cent, 88 real_per_cent: REAL; 89 90 bucket_num, 91 clock_grain, 92 bucket_size, 93 prog_low_pa, 94 prog_high_pa, 95 dos_pa, 96 hit_io, 97 hit_dos, 98 hit_high: WORD; 99 100 seg, 101 offset, 102 parcel: WORD; 103 104 address: WORD; 105 new_line_no, 106 line_no: WORD; 107 108 dummy : LSTRING (8); 109 name: LSTRING (20); 110 line_no_part: LSTRING (17); 111 start: LSTRING (6); 112 113 buckets: ^SUPER ARRAY [1 .. *] OF REAL; 114 115 this_bucket: WORD; 116 117LABEL 1; 118 119 120PROCEDURE filbm (VAR prffil, hstfil, mapfil: filenam; 121 VAR switches: sets); EXTERN; 122 123FUNCTION realword (w: WORD): REAL; 124BEGIN 125 IF ORD (w) < 0 THEN BEGIN 126 realword := FLOAT (maxint) + FLOAT (ORD (w - maxint)); 127 END 128 ELSE BEGIN 129 realword := FLOAT (ORD(w)); 130 END {IF}; 131END {realword}; 132 133 134 135PROCEDURE skip_spaces; 136BEGIN 137 WHILE NOT eof(map) AND THEN map^ = ' ' DO BEGIN 138 get (map); 139 END {WHILE}; 140END {skip_spaces}; 141 142 143FUNCTION hex_char (ch: CHAR): WORD; 144BEGIN 145 IF ch >= '0' AND THEN ch <= '9' THEN BEGIN 146 hex_char := WRD (ch) - WRD ('0'); 147 END 148 ELSE IF ch >= 'A' AND THEN ch <= 'F' THEN BEGIN 149 hex_char := WRD (ch) - WRD ('A') + 10; 150 END 151 ELSE BEGIN 152 WRITELN ('Invalid hex character'); 153 hex_char := 0; 154 END {IF}; 155END {hex_char}; 156 157 158FUNCTION read_hex (i :WORD): WORD; 159VAR 160 hex_val: WORD; 161BEGIN 162 skip_spaces; 163 hex_val := 0; 164 WHILE NOT eof (map) AND THEN i <> 0 DO BEGIN 165 hex_val := hex_val * 16 + hex_char (map^); 166 GET (map); 167 i := i - 1; 168 END {WHILE}; 169 read_hex := hex_val; 170END {read_hex}; 171 172FUNCTION read_h: WORD; 173BEGIN 174 read_h := read_hex (4); 175 get (map); 176 get (map); 177END; 178 179FUNCTION read_word: WORD; 180VAR 181 int_value: WORD; 182BEGIN 183 int_value := 0; 184 IF NOT EOF (map) THEN BEGIN 185 READ (map, int_value); 186 END {IF}; 187 read_word := int_value; 188END {read_word}; 189 190 191FUNCTION map_digit: BOOLEAN; 192BEGIN 193 map_digit := (map^ >= '0') OR (map^ <= '9'); 194END {map_digit}; 195 196BEGIN {prohst} 197 writeln (output, ' Profile Histogram Utility - Version 1.0'); 198 writeln (output); 199 writeln (output, ' Copyright - Microsoft, 1983'); 200 201 start := ' '; 202 203 filbm (bucket_name, hist_name, map_name, switches); 204 205 IF 31 IN switches THEN BEGIN 206 ABORT ('Map file must not be terminal', 0, 0); 207 END {IF}; 208 209 IF NOT (28 IN switches) THEN BEGIN 210 ABORT ('No histogram file specified', 0, 0); 211 END {IF}; 212 213 ASSIGN (bucket, bucket_name); 214 reset (bucket); 215 ASSIGN (hist, hist_name); 216 rewrite (hist); 217 218 map_avail := 29 IN switches; 219 line_nos_avail := FALSE; 220 221 IF map_avail THEN BEGIN 222 ASSIGN (map, map_name); 223 RESET (map); 224 225 WHILE NOT EOF (map) AND THEN start <> ' Start' DO BEGIN 226 READLN (map, start); 227 END {WHILE}; 228 229 NEW (first_address); 230 this_address := NIL; 231 232 WHILE NOT EOF(map) DO BEGIN 233 READLN (map, line); 234 IF line.len < 6 OR ELSE line [2] < '0' OR ELSE 235 line [2] > '9' THEN BEGIN 236 BREAK; 237 END {IF}; 238 239 IF this_address <> NIL THEN BEGIN 240 NEW (this_address^.next); 241 this_address := this_address^.next; 242 END 243 ELSE BEGIN 244 this_address := first_address; 245 END {IF}; 246 this_address^.next := NIL; 247 248 this_address^.address := (hex_char (line [2]) * 4096) + 249 (hex_char (line [3]) * 256) + 250 (hex_char (line [4]) * 16) + 251 hex_char (line [5]); 252 253 FOR i := 1 TO 15 DO BEGIN 254 this_address^.name [i] := line [22 + i]; 255 END {FOR}; 256 257 END {WHILE}; 258 259 WHILE NOT EOF (map) DO BEGIN 260 READLN (map, line_no_part); 261 IF line_no_part = 'Line numbers for ' THEN BEGIN 262 line_nos_avail := TRUE; 263 BREAK; 264 END {IF}; 265 END {WHILE}; 266 267 END {IF}; 268 269 read (bucket, clock_grain, bucket_num, bucket_size, 270 prog_low_pa, prog_high_pa, dos_pa, hit_io, hit_dos, hit_high); 271 272 NEW (buckets,ORD (bucket_num)); 273 274 norm := 0.0; 275 norm_bucket := 0.0; 276 277 FOR i := 1 TO ORD (bucket_num) DO BEGIN 278 read (bucket, this_bucket); 279 real_bucket := realword (this_bucket); 280 281 IF real_bucket > norm_bucket THEN BEGIN 282 norm_bucket := real_bucket; 283 END {IF}; 284 285 norm := norm + real_bucket; 286 buckets^[i] := real_bucket; 287 END {FOR}; 288 norm_bucket := 45.0/norm_bucket; 289 norm := 100.0/norm; 290 291 WRITELN (hist, 'Microsoft Profiler Output Listing'); 292 293 WRITELN (hist); 294 WRITELN (hist, ORD (bucket_num):6, bucket_size:4,'-byte buckets.'); 295 296 WRITELN (hist); 297 WRITELN (hist, 'Profile taken between ', prog_low_pa*16::16, 298 ' and ', prog_high_pa*16::16, '.'); 299 300 WRITELN (hist); 301 WRITELN (hist, 'DOS program address:', dos_pa::16); 302 303 WRITELN (hist); 304 WRITELN (hist, 'Number of hits in DOS: ', hit_dos:5, 305 ' or ', realword (hit_dos) * norm:4:1, '%.'); 306 WRITELN (hist, 'Number of hits in I/O: ', hit_io:5, 307 ' or ', realword (hit_io) * norm:4:1, '%.'); 308 WRITELN (hist, 'Number of hits high : ', hit_high:5, 309 ' or ', realword (hit_high) * norm:4:1, '%.'); 310 WRITELN (hist); 311 WRITELN (hist, ' Hits Addr. Line/ Cumul. % 0.0 ', 312 ' ', 313 1.0/norm:1:1); 314 315 WRITELN (hist, ' Offset +----------------', 316 '----------------------------'); 317 WRITELN (hist, name); 318 i := 0; 319 parcel := 0; 320 current_base := 0; 321 line_no := 0; 322 new_line_no := 0; 323 cum_per_cent := 0.0; 324 325 WHILE i < ORD (bucket_num) DO BEGIN 326 i := i + 1; 327 IF buckets^[i] < 0.9 THEN BEGIN 328 WRITELN (hist); 329 REPEAT 330 i := i + 1; 331 UNTIL (i = ORD (bucket_num)) OR ELSE buckets^[i] > 0.0; 332 END {IF}; 333 334 address := bucket_size * (WRD (i) - 1); 335 336 WHILE map_avail AND THEN 337 address >= first_address^.address DO BEGIN 338 WRITELN (hist, ' ', first_address^.name); 339 current_base := first_address^.address; 340 first_address := first_address^.next; 341 END {WHILE}; 342 343 WHILE line_nos_avail AND THEN NOT eof (map) AND THEN 344 address >= parcel DO BEGIN 345 skip_spaces; 346 WHILE (map^ < '0') OR (map^ > '9') DO BEGIN 347 348 IF EOF (map) THEN BEGIN 349 goto 1; 350 END {IF}; 351 READLN (map); 352 skip_spaces; 353 END {WHILE}; 354 355 356 line_no := new_line_no; 357 new_line_no := read_word; 358 seg := read_hex (4); 359 IF EOF (map) THEN BEGIN 360 GOTO 1; 361 END {IF}; 362 IF map^ <> ':' THEN BEGIN 363 WRITELN ('Invalid map file'); 364 END {IF}; 365 get (map); 366 IF EOF (map) THEN BEGIN 367 GOTO 1; 368 END {IF}; 369 offset := read_hex (3) + WRD (hex_char (map^) > 0); 370 get (map); 371 IF map^ <> 'H' THEN BEGIN 372 WRITELN ('Invalid map file'); 373 END {IF}; 374 IF EOF (map) THEN BEGIN 375 GOTO 1; 376 END {IF}; 377 get (map); 378 parcel := seg + offset; 379 END {WHILE}; 3801: real_per_cent := buckets^[i] * norm; 381 cum_per_cent := cum_per_cent + real_per_cent; 382 per_cent := ROUND ( buckets^[i] * norm_bucket); 383 384 WRITE (hist, buckets^ [i]:6:0, ' ', 385 address*16:6:16); 386 IF line_no <> 0 THEN BEGIN 387 WRITE (hist, line_no:6); 388 line_no := 0; 389 END 390 ELSE IF map_avail AND THEN first_address <> NIL THEN BEGIN 391 WRITE (hist, ' #', address - first_address^.address:4:16); 392 END 393 ELSE BEGIN 394 WRITE (hist, ' '); 395 END {IF}; 396 397 WRITELN (hist, ' ', cum_per_cent:5:1, ' ', real_per_cent:4:1, ' |', 398 '*': per_cent); 399 END {WHILE}; 400 WRITELN (hist, ' +-----------------', 401 '------------------'); 402END. 403[FILE END](C) 2025 0x4248 (C) 2025 4248 Media and 4248 Systems, All part of 0x4248 See LICENCE files for more information. Not all files are by 0x4248 always check Licencing.