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 profile:
38 pf:
39 procedure;
40
41
42
43 declare arg_len fixed binary (21);
44 declare arg_ptr ptr;
45 declare 1 args,
46 2 brief bit (1),
47 2 comment bit (1),
48 2 exclude bit (1),
49 2 first bit (1),
50 2 from bit (1),
51 2 hardcore bit (1),
52 2 input_file bit (1),
53 2 last bit (1),
54 2 line_length bit (1),
55 2 list bit (1),
56 2 long bit (1),
57 2 max_points bit (1),
58 2 no_header bit (1),
59 2 output_file bit (1),
60 2 plot bit (1),
61 2 print bit (1),
62 2 reset bit (1),
63 2 search_dir bit (1),
64 2 sort bit (1),
65 2 source_dir bit (1),
66 2 to bit (1);
67 declare code fixed binary (35);
68 declare comment char (128);
69 declare comparing bit (1);
70 declare dirname char (168);
71 declare entryname char (32);
72 declare exclude_fields (5) bit (1);
73 declare exit bit (1);
74 declare first fixed binary (35);
75 declare from fixed binary (35);
76 declare i fixed binary (18);
77 declare input_file char (168);
78 declare interval fixed binary (18);
79 declare j fixed binary (18);
80 declare k fixed binary (18);
81 declare 1 last_temp_data_word aligned like msf_ptr_template;
82 declare line_buffer char (1200) varying;
83 declare line_length fixed binary (35);
84 declare list_iocb ptr;
85 declare max_points fixed binary (35);
86 declare n_program_names fixed binary;
87 declare n_search_paths fixed binary;
88 declare n_values fixed binary (18);
89 declare output_fcb ptr;
90 declare output_file char (168);
91 declare 1 pfd_file_control aligned,
92 2 fcb ptr,
93 2 last_component fixed binary,
94 2 component (0:9) ptr;
95 declare plot_field (5) bit (1);
96 declare prog_nr fixed binary;
97 declare program_name_array (100) fixed binary;
98 declare search_path (8) char (168);
99 declare sort_field (5) bit (1);
100 declare source_dir char (168);
101 declare source_ptr ptr;
102 declare temp_seg_array (3) ptr;
103 declare to fixed binary (35);
104 declare value fixed binary (18);
105 declare y_legend fixed binary;
106
107
108
109 declare arg char (arg_len) based (arg_ptr);
110
111
112
113 declare addr builtin;
114 declare addrel builtin;
115 declare baseno builtin;
116 declare bin builtin;
117 declare clock builtin;
118 declare codeptr builtin;
119 declare divide builtin;
120 declare float builtin;
121 declare hbound builtin;
122 declare index builtin;
123 declare length builtin;
124 declare min builtin;
125 declare mod builtin;
126 declare null builtin;
127 declare ptr builtin;
128 declare reverse builtin;
129 declare rtrim builtin;
130 declare search builtin;
131 declare size builtin;
132 declare stackbaseptr builtin;
133 declare string builtin;
134 declare substr builtin;
135 declare unspec builtin;
136
137
138
139 declare cleanup condition;
140
141
142
143 declare HT char (1) internal static options (constant) initial (" ");
144 declare HT_NL char (2) internal static options (constant) initial ("
145 ");
146 declare NL char (1) internal static options (constant) initial ("
147 ");
148 declare me char (7) internal static options (constant) initial ("profile");
149 declare profile_data_suffix char (3) internal static options (constant) initial ("pfd");
150 declare profile_listing_suffix char (3) internal static options (constant) initial ("pfl");
151 declare table_1 (5) char (12) internal static options (constant)
152 initial ("count", "cost", "time", "page_faults", "pfs");
153 declare table_1_upper_case (5) char (12) internal static options (constant)
154 initial ("COUNT", "COST", "TIME", "PAGE FAULTS", "PAGE FAULTS");
155
156
157
158 declare error_table_$badopt fixed binary (35) external static;
159 declare error_table_$bigarg fixed binary (35) external static;
160 declare error_table_$file_is_full
161 fixed binary (35) external static;
162 declare error_table_$improper_data_format
163 fixed binary (35) external static;
164 declare error_table_$inconsistent
165 fixed binary (35) external static;
166 declare error_table_$name_not_found
167 fixed binary (35) external static;
168 declare error_table_$noarg fixed binary (35) external static;
169 declare error_table_$noentry fixed binary (35) external static;
170 declare error_table_$too_many_args
171 fixed binary (35) external static;
172 declare error_table_$zero_length_seg
173 fixed binary (35) external static;
174 declare iox_$user_output ptr external static;
175 declare sys_info$max_seg_size fixed binary (19) external static;
176
177
178
179 declare absolute_pathname_ entry (char (*), char (*), fixed binary (35));
180 declare com_err_ entry options (variable);
181 declare com_err_$suppress_name entry options (variable);
182 declare cu_$arg_count entry (fixed binary);
183 declare cu_$arg_ptr entry (fixed binary, ptr, fixed binary (21), fixed binary (35));
184 declare cv_dec_check_ entry (char (*), fixed binary (35)) returns (fixed binary (35));
185 declare cv_ptr_ entry (char (*), fixed binary (35)) returns (ptr);
186 declare date_time_ entry (fixed binary (71), char (*));
187 declare expand_pathname_ entry (char (*), char (*), char (*), fixed binary (35));
188 declare expand_pathname_$add_suffix
189 entry (char (*), char (*), char (*), char (*), fixed binary (35));
190 declare find_operator_name_ entry (char (*), ptr, char (32) aligned);
191 declare get_group_id_ entry () returns (char (32));
192 declare get_temp_segment_ entry (char (*), ptr, fixed binary (35));
193 declare hcs_$initiate_count entry (char (*), char (*), char (*), fixed binary (24), fixed binary (2), ptr,
194 fixed binary (35));
195 declare hcs_$terminate_noname entry (ptr, fixed binary (35));
196 declare ioa_ entry options (variable);
197 declare ioa_$ioa_switch entry options (variable);
198 declare ioa_$ioa_switch_nnl entry options (variable);
199 declare iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed binary (35));
200 declare iox_$close entry (ptr, fixed binary (35));
201 declare iox_$detach_iocb entry (ptr, fixed binary (35));
202 declare iox_$open entry (ptr, fixed binary, bit (1) aligned, fixed binary (35));
203 declare iox_$put_chars entry (ptr, ptr, fixed binary (21), fixed binary (35));
204 declare msf_manager_$adjust entry (ptr, fixed binary, fixed binary (24), bit (3), fixed binary (35));
205 declare msf_manager_$close entry (ptr);
206 declare msf_manager_$get_ptr entry (ptr, fixed binary, bit (1), ptr, fixed binary (24), fixed binary (35));
207 declare msf_manager_$open entry (char (*), char (*), ptr, fixed binary (35));
208 declare release_temp_segments_ entry (char (*), (*) ptr, fixed binary (35));
209 declare ring0_get_$name entry (char (*), char (*), ptr, fixed binary (35));
210 declare ring0_get_$segptr entry (char (*), char (*), ptr, fixed binary (35));
211 declare ring_zero_peek_ entry (ptr, ptr, fixed binary (18), fixed binary (35));
212 declare unique_chars_ entry (bit (*)) returns (char (15));
213 ^L
214 %include pfd_format;
215 %include lot;
216 %include linkdcl;
217 %include stack_header;
218 %include std_symbol_header;
219
220
221
222 %include symbol_header;
223 %include pl1_symbol_block;
224 %include source_map;
225 %include statement_map;
226 %include profile_entry;
227 %include long_profile;
228 %include plot_entry_dcls;
229 %include iox_modes;
230 ^L
231
232
233 call initialize;
234 on cleanup
235 call clean;
236
237 call get_arguments;
238
239
240
241 if args.input_file
242 then call open_input_file;
243 else call scan_data ("1"b);
244
245
246
247 if args.output_file
248 then call store_output_file;
249
250
251
252 if args.list
253 then call print_or_list ("1"b);
254
255 if args.plot
256 then call plot;
257
258 if args.print
259 then call print_or_list ("0"b);
260
261
262
263 if args.reset
264 then call scan_data ("0"b);
265
266
267
268 quit:
269 call clean;
270 return;
271 ^L
272
273
274 err_check:
275 procedure;
276
277 if code ^= 0
278 then call error (code, "");
279 end err_check;
280
281 error:
282 procedure (code, text);
283 declare code fixed binary (35);
284 declare text char (*);
285
286 call com_err_ (code, me, "^a", text);
287 goto quit;
288 end error;
289
290 file_error:
291 procedure;
292
293 call com_err_ (code, me, "^a>^a", dirname, entryname);
294 goto quit;
295 end file_error;
296 ^L
297
298
299 initialize:
300 procedure;
301
302
303
304 temp_seg_array (*) = null;
305
306 pfd_file_control.component (*) = null;
307 pfd_file_control.fcb = null;
308
309 output_fcb = null;
310 source_ptr = null;
311 list_iocb = null;
312
313
314
315 n_search_paths = 0;
316 n_program_names = 0;
317 string (args) = ""b;
318 end initialize;
319
320
321
322 clean:
323 procedure;
324
325 call release_temp_segments_ (me, temp_seg_array, code);
326 call release_temp_segments_ (me, pfd_file_control.component, code);
327
328 if pfd_file_control.fcb ^= null
329 then do;
330 call msf_manager_$close (pfd_file_control.fcb);
331 pfd_file_control.fcb = null;
332 end;
333
334 if output_fcb ^= null
335 then do;
336 call msf_manager_$adjust (output_fcb, 0, 0, "111"b, code);
337 call msf_manager_$close (output_fcb);
338 output_fcb = null;
339 end;
340
341 if source_ptr ^= null
342 then do;
343 call hcs_$terminate_noname (source_ptr, code);
344 source_ptr = null;
345 end;
346
347 if list_iocb ^= null
348 then do;
349 call iox_$close (list_iocb, code);
350 call iox_$detach_iocb (list_iocb, code);
351 list_iocb = null;
352 end;
353 end clean;
354 ^L
355
356
357 get_arguments:
358 procedure;
359
360 declare arg_nr fixed binary;
361 declare n_args fixed binary;
362 declare operand_len fixed binary (21);
363 declare operand_ptr ptr;
364
365 declare operand char (operand_len) based (operand_ptr);
366
367 call cu_$arg_count (n_args);
368 do arg_nr = 1 to n_args;
369 call cu_$arg_ptr (arg_nr, arg_ptr, arg_len, code);
370 call err_check;
371
372 if index (arg, "-") = 1
373 then if arg = "-pr" | arg = "-print"
374 then args.print = "1"b;
375
376 else if arg = "-nhe" | arg = "-no_header"
377 then args.no_header = "1"b;
378
379 else if arg = "-sort"
380 then call accept_field (args.sort, sort_field, "0"b, table_1, (0));
381
382 else if arg = "-ft" | arg = "-first"
383 then call accept_number (args.first, first, "first");
384
385 else if arg = "-lg" | arg = "-long"
386 then do;
387 args.brief = "0"b;
388 args.long = "1"b;
389 end;
390
391 else if arg = "-ls" | arg = "-list"
392 then args.list = "1"b;
393
394 else if arg = "-scd" | arg = "-source_dir"
395 then call accept_pathname (args.source_dir, source_dir);
396
397 else if arg = "-ll" | arg = "-line_length"
398 then call accept_number (args.line_length, line_length, "line_length");
399
400 else if arg = "-plot"
401 then call accept_field (args.plot, plot_field, "0"b, table_1, y_legend);
402
403 else if arg = "-fm" | arg = "-from"
404 then call accept_number (args.from, from, "from");
405
406 else if arg = "-to"
407 then call accept_number (args.to, to, "to");
408
409 else if arg = "-mp" | arg = "-max_points"
410 then call accept_number (args.max_points, max_points, "max_points");
411
412 else if arg = "-of" | arg = "-output_file"
413 then call accept_pathname (args.output_file, output_file);
414
415 else if arg = "-com" | arg = "-comment"
416 then call accept_string (args.comment, comment);
417
418 else if arg = "-if" | arg = "-input_file"
419 then call accept_pathname (args.input_file, input_file);
420
421 else if arg = "-rs" | arg = "-reset"
422 then args.reset = "1"b;
423
424 else if arg = "-hard" | arg = "-hardcore"
425 then args.hardcore = "1"b;
426
427 else if arg = "-srhd" | arg = "-search_dir"
428 then call accept_search_path;
429
430 else if arg = "-bf" | arg = "-brief"
431 then do;
432 args.brief = "1"b;
433 args.long = "0"b;
434 end;
435
436 else call error (error_table_$badopt, arg);
437
438
439
440 else do;
441 if search (arg, "$|") ^= 0
442 then call error (0, "Invalid program name. " || arg);
443
444 if n_program_names >= hbound (program_name_array, 1)
445 then call error (error_table_$too_many_args, "Program names.");
446
447 n_program_names = n_program_names + 1;
448 program_name_array (n_program_names) = arg_nr;
449 end;
450 end;
451
452
453
454 if ^args.line_length
455 then line_length = 132;
456
457 if ^args.max_points
458 then max_points = 250;
459
460 if args.hardcore & ^args.search_dir
461 then do;
462 n_search_paths = 1;
463 search_path (1) = ">ldd>hard>o";
464 end;
465
466 if ^args.list & ^args.plot & ^args.output_file & ^args.reset
467 then args.print = "1"b;
468
469 if args.print & ^args.long
470 then args.brief = "1"b;
471
472
473
474 if n_program_names = 0 & ^args.input_file
475 then do;
476 call com_err_$suppress_name (0, me, "Usage: ^a {program_names} {-control_args}", me);
477 goto quit;
478 end;
479
480 if args.sort & ^args.print
481 then call missing ("sort", "print");
482
483 if args.first & ^args.sort
484 then call missing ("first", "sort");
485
486 if args.no_header & ^args.print
487 then call missing ("no_header", "print");
488
489 if args.brief & ^args.print
490 then call missing ("brief", "print");
491
492 if args.long & ^args.print
493 then call missing ("long", "print");
494
495 if args.line_length & ^args.list
496 then call missing ("line_length", "list");
497
498 if line_length < 50
499 then call error (error_table_$improper_data_format, "Line length too small.");
500
501 if args.from & ^args.print & ^args.plot
502 then call missing ("from", "print or -plot");
503
504 if args.to & ^args.print & ^args.plot
505 then call missing ("to", "print or -plot");
506
507 if args.comment & ^args.output_file & ^args.plot
508 then call missing ("comment", "output_file or -plot");
509
510 if args.max_points & ^args.plot
511 then call missing ("max_points", "plot");
512
513 if args.search_dir & ^args.hardcore
514 then call missing ("search_dir", "hardcore");
515
516 if args.source_dir & ^args.list
517 then call missing ("source_dir", "list");
518
519 if args.reset & args.input_file
520 then call error (error_table_$inconsistent, "-reset and -input_file");
521
522 if args.reset & args.hardcore
523 then call error (error_table_$inconsistent, "-reset and -hardcore");
524
525 if args.output_file & args.input_file
526 then call error (error_table_$inconsistent, "-input_file and -output_file");
527
528 if args.comment & args.input_file
529 then call error (error_table_$inconsistent, "-comment and -input_file");
530
531 if args.hardcore & args.input_file
532 then call error (error_table_$inconsistent, "-hardcore and -input_file");
533
534 if args.sort & args.to
535 then call error (error_table_$inconsistent, "-sort and -to");
536
537 if args.sort & args.from
538 then call error (error_table_$inconsistent, "-sort and -from");
539
540 return;
541 ^L
542
543
544 accept_number:
545 procedure (arg_flag, value, text);
546 declare arg_flag bit (1);
547 declare value fixed binary (35);
548 declare text char (*);
549
550 call get_next_arg;
551 value = cv_dec_check_ (operand, code);
552 if code ^= 0 | value < 0
553 then call error (error_table_$improper_data_format, "After -" || text || ". " || operand);
554
555 arg_flag = "1"b;
556 end accept_number;
557
558 accept_string:
559 procedure (arg_flag, value);
560 declare arg_flag bit (1);
561 declare value char (*);
562
563 call get_next_arg;
564 if length (operand) > length (value)
565 then call error (error_table_$bigarg, operand);
566
567 value = operand;
568 arg_flag = "1"b;
569 end accept_string;
570
571 accept_pathname:
572 procedure (arg_flag, value);
573 declare arg_flag bit (1);
574 declare value char (*);
575
576 call get_next_arg;
577
578 call absolute_pathname_ (operand, value, code);
579 if code ^= 0
580 then call error (code, operand);
581
582 arg_flag = "1"b;
583 end accept_pathname;
584 ^L
585 accept_field:
586 procedure (arg_flag, value, inclusive, table, subscript);
587 declare arg_flag bit (1);
588 declare value (*) bit (1);
589 declare inclusive bit (1);
590 declare table (*) char (*);
591 declare subscript fixed binary;
592
593 call get_next_arg;
594 do i = 1 to hbound (table, 1) while (table (i) ^= operand);
595 end;
596 if i > hbound (table, 1)
597 then call error (0, "Invalid field name. " || operand);
598
599 if ^arg_flag | ^inclusive
600 then value (*) = "0"b;
601
602 value (i) = "1"b;
603 subscript = i;
604 arg_flag = "1"b;
605 end accept_field;
606
607 accept_search_path:
608 procedure;
609
610 if n_search_paths >= hbound (search_path, 1)
611 then call error (error_table_$too_many_args, "Search paths.");
612
613 n_search_paths = n_search_paths + 1;
614 call accept_pathname (args.search_dir, search_path (n_search_paths));
615 end accept_search_path;
616
617 get_next_arg:
618 procedure;
619
620 arg_nr = arg_nr + 1;
621 if arg_nr > n_args
622 then call error (error_table_$noarg, "Value for " || arg || ".");
623
624 call cu_$arg_ptr (arg_nr, operand_ptr, operand_len, code);
625 call err_check;
626 end get_next_arg;
627
628 missing:
629 procedure (dependent_arg, main_arg);
630 declare dependent_arg char (*);
631 declare main_arg char (*);
632
633 call com_err_ (0, me, "Invalid specification of -^a without -^a.", dependent_arg, main_arg);
634 goto quit;
635 end missing;
636
637 end get_arguments;
638 ^L
639
640
641 open_input_file:
642 procedure;
643
644 declare arg_program_name char (32);
645
646 call expand_pathname_$add_suffix (input_file, profile_data_suffix, dirname, entryname, code);
647 if code ^= 0
648 then call error (code, input_file);
649
650 call msf_manager_$open (dirname, entryname, pfd_file_control.fcb, code);
651 if pfd_file_control.fcb = null | code = error_table_$noentry
652 then call file_error;
653
654 exit = "0"b;
655 do i = 0 to hbound (pfd_file_control.component, 1) while (^exit);
656 call msf_manager_$get_ptr (pfd_file_control.fcb, (i), "0"b , pfd_file_control.component (i),
657 (0), code);
658 if pfd_file_control.component (i) = null
659 then exit = "1"b;
660 end;
661
662
663
664 pfd_ptr = pfd_file_control.component (0);
665 if pfd_header.version ^= pfd_format_version_1
666 then do;
667 code = error_table_$improper_data_format;
668 call file_error;
669 end;
670
671
672
673 do prog_nr = 1 to n_program_names;
674 arg_program_name = get_program_name (prog_nr);
675
676 exit = "0"b;
677 do program_ptr = ptr_from_msf_ptr (pfd_header.first_program)
678 repeat ptr_from_msf_ptr (program.next_program) while (program_ptr ^= null & ^exit);
679 exit = arg_program_name = program.name;
680 end;
681
682 if ^exit
683 then call error (0,
684 "Program not in profile data file. " || rtrim (arg_program_name) || " not in " || rtrim (dirname)
685 || ">" || rtrim (entryname));
686 end;
687 end open_input_file;
688 ^L
689
690
691
692
693 scan_data:
694 procedure (constructing);
695 declare constructing bit (1);
696
697 declare another_component bit (1);
698 declare bound_object_segment bit (1);
699 declare 1 found,
700 2 profile bit (1),
701 2 symbol_table bit (1),
702 2 data bit (1);
703 declare hardcore_bound_segpath char (168);
704 declare hardcore_object_ptr ptr;
705 declare hardlp ptr;
706 declare hp ptr;
707 declare last_program_ptr ptr;
708 declare linkage_copy_ptr ptr;
709 declare lp ptr;
710 declare p ptr;
711
712
713
714
715 if args.hardcore
716 then call get_seg (1, linkage_copy_ptr);
717
718
719
720 if constructing
721 then do;
722 call get_seg (2, program_ptr);
723 call get_seg (3, value_ptr);
724
725 pfd_file_control.last_component = -1;
726 call extend_temp_data_file;
727 pfd_ptr = pfd_file_control.component (0);
728
729
730
731 pfd_header.version = pfd_format_version_1;
732 pfd_header.mbz = "0"b;
733 pfd_header.date_time_stored = clock ();
734 pfd_header.person_project = get_group_id_ ();
735 pfd_header.first_program = null_msf_ptr;
736
737 if args.comment
738 then pfd_header.comment = comment;
739 else pfd_header.comment = "";
740
741 last_temp_data_word.component = 0;
742 last_temp_data_word.offset = size (pfd_header) - 1;
743
744 last_program_ptr = null;
745 end;
746
747
748
749 hardlp = null;
750 sb = stackbaseptr ();
751
752
753
754 do prog_nr = 1 to n_program_names;
755 call cu_$arg_ptr (program_name_array (prog_nr), arg_ptr, arg_len, code);
756 call err_check;
757
758
759
760 string (found) = ""b;
761
762
763
764
765
766 if args.hardcore
767 then begin;
768 declare hardcore_bound_segname char (32);
769
770 call ring0_get_$segptr ("", arg, hardcore_object_ptr, code);
771
772 if code = 0
773 then call ring0_get_$name ("", hardcore_bound_segname, ptr (hardcore_object_ptr, 0), code);
774
775 if code = 0
776 then begin;
777 declare search_nr fixed binary;
778
779 code = error_table_$noentry;
780 do search_nr = 1 to n_search_paths while (code ^= 0);
781 hardcore_bound_segpath =
782 rtrim (search_path (search_nr)) || ">" || hardcore_bound_segname;
783
784 call find_object (hardcore_bound_segpath, p, hp, bound_object_segment, code);
785
786 end;
787 end;
788 end;
789 else call find_object (arg, p, hp, bound_object_segment, code);
790
791 if code ^= 0
792 then if code = error_table_$name_not_found
793 then call error (0, "Reference name not found. Program has not been executed. " || arg);
794 else call error (code, arg);
795
796
797
798 if args.hardcore
799 then begin;
800 declare hardcore_object_segnr fixed binary;
801 declare 1 lot_item aligned,
802 2 linkage_ptr ptr unaligned;
803 declare lot_ptr ptr;
804
805 hardcore_object_segnr = bin (baseno (hardcore_object_ptr));
806 call ring0_get_$segptr ("", "lot", lot_ptr, code);
807
808 call err_check;
809
810 call ring_zero_peek_ (addrel (lot_ptr, hardcore_object_segnr), addr (lot_item), 1, code);
811 call err_check;
812
813 if unspec (lot_item) = "0"b
814 then call error (error_table_$noentry, arg);
815
816
817 lp = lot_item.linkage_ptr;
818 end;
819 else begin;
820 declare object_segnr fixed binary;
821
822 object_segnr = bin (baseno (p));
823 isotp = stack_header.isot_ptr;
824
825 if unspec (isot.isp (object_segnr)) = "0"b | (isotp -> isot1(object_segnr).fault = "11"b)
826 then call error (0, "Program has not been executed. " || arg);
827
828 lp = isot.isp (object_segnr);
829 end;
830
831
832
833 another_component = "1"b;
834 do while (another_component);
835 call scan_component;
836
837 another_component = p -> std_symbol_header.next_block ^= ""b;
838 if another_component
839 then p = addrel (hp, p -> std_symbol_header.next_block);
840 end;
841
842
843
844 if ^found.profile
845 then call error (0, "Program was not compiled with -profile. " || arg);
846
847 if ^found.symbol_table
848 then call error (0, "Program's symbol table has been removed. " || arg);
849
850 if ^found.data & constructing
851 then call error (0, "Program has not been executed since its profile data was reset. " || arg);
852 end;
853
854 return;
855 ^L
856
857
858 scan_component:
859 procedure;
860
861 declare 1 last_temp_data aligned like msf_ptr_template;
862 declare long bit (1);
863 declare map ptr;
864 declare overhead fixed binary;
865 declare pf ptr;
866 declare pf_loc bit (18);
867 declare pfh ptr;
868 declare q ptr;
869 declare sp ptr;
870 declare total_cost_or_time fixed binary (35);
871 declare total_count fixed binary (35);
872 declare total_page_faults fixed binary (35);
873
874 if p -> std_symbol_header.identifier ^= "symbtree"
875 then if p -> symbol_header.translator.code = "010100000"b
876 then call error (0, arg || " is not a standard object segment.");
877 else return;
878
879 if p -> std_symbol_header.area_pointer = "0"b
880 then return;
881
882 q = addrel (p, p -> std_symbol_header.area_pointer);
883 if q -> pl1_symbol_block.identifier ^= "pl1info"
884 then return;
885
886 long = q -> pl1_symbol_block.flags.long_profile;
887
888 if ^q -> pl1_symbol_block.flags.profile & ^long
889 then return;
890
891 pf_loc = q -> pl1_symbol_block.profile;
892
893
894
895 found.profile = "1"b;
896
897 if q -> pl1_symbol_block.table_removed
898 then return;
899
900 found.symbol_table = "1"b;
901
902
903
904 if constructing
905 then begin;
906 declare source_map_ptr ptr;
907 declare string_len fixed binary (21);
908 declare string_ptr ptr;
909
910 declare based_string char (string_len) based (string_ptr);
911
912 program.next_program = null_msf_ptr;
913
914 string_ptr = addrel (p, q -> pl1_symbol_block.segname.offset);
915 string_len = bin (q -> pl1_symbol_block.segname.size);
916 program.name = based_string;
917
918 if args.output_file & ^bound_object_segment & get_program_name (prog_nr) ^= program.name
919 then call com_err_ (0, me, "Name of ^a in profile data file is ^a.", arg, program.name);
920
921 program.translator = p -> std_symbol_header.generator;
922 program.flags.long_profile = long;
923 program.flags.mbz = "0"b;
924 program.source_path_array = null_msf_ptr;
925 program.n_operators = 0;
926 program.operator_array = null_msf_ptr;
927 program.n_values = 0;
928 program.value_array = null_msf_ptr;
929
930 source_map_ptr = addrel (p, p -> std_symbol_header.source_map);
931 program.last_source_path = source_map_ptr -> source_map.number - 1;
932
933 source_path_ptr = addrel (program_ptr, size (program));
934 operator_ptr = addrel (source_path_ptr, size (source_path_array));
935
936 do i = 0 to hbound (source_path_array, 1);
937 string_ptr = addrel (p, source_map_ptr -> source_map.map (i + 1).pathname.offset);
938 string_len = bin (source_map_ptr -> source_map.map (i + 1).pathname.size);
939 source_path_array (i) = based_string;
940 end;
941
942 total_count = 0;
943 total_cost_or_time = 0;
944 total_page_faults = 0;
945 end;
946
947
948
949 sp = addrel (p, q -> pl1_symbol_block.map.first);
950
951 if args.hardcore
952 then do;
953 if hardlp ^= lp
954 then begin;
955 declare bword bit (36) aligned based;
956 declare 1 copy_lh aligned like header;
957
958 declare same bit (1);
959 declare word bit (36) aligned;
960 declare reloff fixed binary (18);
961
962 reloff = bin (p -> std_symbol_header.mini_truncate) - 1;
963 call ring_zero_peek_ (addrel (hardcore_object_ptr, reloff), addr (word), 1, code);
964
965 if code = 0
966 then same = ptr (hp, reloff) -> bword = word;
967 else same = "0"b;
968
969 if ^same
970 then do;
971 call com_err_ (0, me, "Hardcore program ^a does not match library copy ^a|^o", arg,
972 hardcore_bound_segpath, reloff);
973 goto quit;
974 end;
975
976 call ring_zero_peek_ (lp, addr (copy_lh), size (copy_lh), code);
977 if code ^= 0
978 then call error (code, arg);
979
980 call ring_zero_peek_ (lp, linkage_copy_ptr, bin (copy_lh.block_length), code);
981 if code ^= 0
982 then call error (code, arg);
983
984 hardlp = lp;
985 end;
986
987 pf = addrel (linkage_copy_ptr, pf_loc);
988 end;
989 else pf = addrel (lp, pf_loc);
990
991
992
993 if long
994 then do;
995 pfh = pf;
996 if pfh -> long_profile_header.control.count ^= 0
997 then begin;
998 declare entry_index fixed binary;
999
1000 overhead =
1001 float (pfh -> long_profile_header.control.vcpu)
1002 / float (pfh -> long_profile_header.control.count);
1003
1004 pf = addrel (pfh, size (long_profile_header));
1005
1006 do entry_index = 1 to pfh -> long_profile_header.nentries;
1007 map = addrel (sp, pf -> long_profile_entry.map);
1008 call scan_statement_data;
1009 pf = addrel (pf, size (long_profile_entry));
1010 end;
1011 end;
1012 end;
1013
1014 else do map = addrel (sp, pf -> profile_entry.map) repeat addrel (sp, pf -> profile_entry.map)
1015 while (map -> statement_map.line ^= (14)"1"b);
1016 call scan_statement_data;
1017 pf = addrel (pf, size (profile_entry));
1018 end;
1019
1020
1021
1022 if ^constructing
1023 then do;
1024 if long
1025 then begin;
1026 declare n fixed binary;
1027
1028 n = pfh -> long_profile_header.nentries;
1029 unspec (pfh -> long_profile_header) = "0"b;
1030 pfh -> long_profile_header.nentries = n;
1031 pfh -> long_profile_header.last_offset = dummy_entry_offset;
1032 end;
1033
1034 return;
1035 end;
1036
1037
1038
1039 program.total_count = total_count;
1040 program.total_cost_or_time = total_cost_or_time;
1041 program.total_page_faults = total_page_faults;
1042
1043
1044
1045
1046 n_values = program.n_values;
1047 interval = n_values;
1048 do while (interval > 1);
1049 interval = 2 * divide (interval, 4, 18) + 1;
1050 do i = 1 to n_values - interval;
1051 k = i + interval;
1052 comparing = "1"b;
1053 do while (comparing);
1054 comparing = "0"b;
1055 j = k - interval;
1056 if unspec (value_array (j).source) > unspec (value_array (k).source)
1057 then begin;
1058 declare 1 temp_value aligned like value_array;
1059
1060 temp_value = value_array (k);
1061 value_array (k) = value_array (j);
1062 value_array (j) = temp_value;
1063 if j > interval
1064 then do;
1065 comparing = "1"b;
1066 k = j;
1067 end;
1068 end;
1069 end;
1070 end;
1071 end;
1072
1073
1074
1075 call store_temp_data (program_ptr, size (program));
1076
1077 if last_program_ptr = null
1078 then pfd_header.first_program = last_temp_data;
1079 else last_program_ptr -> program.next_program = last_temp_data;
1080
1081 last_program_ptr = ptr_from_msf_ptr (last_temp_data);
1082
1083 call store_temp_data (source_path_ptr, size (source_path_array));
1084 last_program_ptr -> program.source_path_array = last_temp_data;
1085
1086 if program.n_operators ^= 0
1087 then do;
1088 call store_temp_data (operator_ptr, size (operator_array));
1089 last_program_ptr -> program.operator_array = last_temp_data;
1090 end;
1091
1092 if program.n_values ^= 0
1093 then do;
1094 call store_temp_data (value_ptr, size (value_array));
1095 last_program_ptr -> program.value_array = last_temp_data;
1096 end;
1097
1098 return;
1099 ^L
1100
1101
1102 scan_statement_data:
1103 procedure;
1104
1105 declare cost_or_time fixed binary (35);
1106 declare count fixed binary (35);
1107 declare instruction fixed binary (35);
1108 declare instruction_array_ptr ptr;
1109 declare map2 ptr;
1110 declare masked_instruction bit (36);
1111 declare n_instructions fixed binary;
1112
1113 declare instruction_array (n_instructions) bit (36) aligned based (instruction_array_ptr);
1114
1115
1116
1117 if ^constructing
1118 then do;
1119 if long
1120 then do;
1121 pf -> long_profile_entry.count = 0;
1122 pf -> long_profile_entry.vcpu = 0;
1123 pf -> long_profile_entry.pf = 0;
1124 end;
1125 else pf -> profile_entry.count = 0;
1126
1127 return;
1128 end;
1129
1130 map2 = addrel (map, size (statement_map));
1131 n_instructions = bin (map2 -> statement_map.location) - bin (map -> statement_map.location);
1132 instruction_array_ptr = ptr (p, map -> statement_map.location);
1133
1134
1135
1136 program.n_values = program.n_values + 1;
1137 value = program.n_values;
1138 value_array (value).source.file = bin (map -> statement_map.file);
1139 value_array (value).source.line = bin (map -> statement_map.line);
1140 value_array (value).source.statement = bin (map -> statement_map.statement);
1141
1142 value_array (value).source.pf_entry_seq = 0;
1143 if value > 1
1144 then if value_array (value).source.file = value_array (value - 1).source.file
1145 & value_array (value).source.line = value_array (value - 1).source.line
1146 & value_array (value).source.statement = value_array (value - 1).source.statement
1147 then value_array (value).source.pf_entry_seq = value_array (value - 1).source.pf_entry_seq + 1;
1148
1149 value_array (value).n_operators = 0;
1150 value_array (value).first_operator = program.n_operators + 1;
1151
1152 if long
1153 then count = pf -> long_profile_entry.count;
1154 else count = pf -> profile_entry.count;
1155
1156 if count ^= 0
1157 then found.data = "1"b;
1158
1159
1160
1161 if long
1162 then i = 2;
1163 else i = 1;
1164
1165 do instruction = i to n_instructions;
1166 masked_instruction = instruction_array (instruction) & "700000777777"b3;
1167 if masked_instruction = "000000700100"b3
1168 | masked_instruction = "000000710100"b3
1169 | masked_instruction = "000000273100"b3
1170 | masked_instruction = "200000272100"b3
1171 | masked_instruction = "000000707100"b3
1172 then do;
1173 program.n_operators = program.n_operators + 1;
1174
1175 value_array (value).n_operators = value_array (value).n_operators + 1;
1176
1177 operator_array (program.n_operators) = instruction_array (instruction);
1178
1179 end;
1180 end;
1181
1182
1183
1184 if long
1185 then do;
1186 if count = 0
1187 then cost_or_time = 0;
1188 else cost_or_time = pf -> long_profile_entry.vcpu - overhead * count;
1189
1190
1191 if cost_or_time < 0
1192 then cost_or_time = 0;
1193 end;
1194
1195 else do;
1196 cost_or_time = n_instructions - 1;
1197 cost_or_time = cost_or_time + 9 * value_array (value).n_operators;
1198
1199
1200
1201
1202
1203 if instruction_array (1) = "600044370120"b3
1204
1205 then begin;
1206 declare epplp bit (1) aligned;
1207 declare use_lp bit (1) aligned;
1208
1209 epplp = "0"b;
1210 use_lp = "0"b;
1211 do instruction = 3 to n_instructions while (^epplp & ^use_lp);
1212 use_lp = (instruction_array (instruction) & "700000000100"b3) = "400000000100"b3;
1213
1214 if ^use_lp
1215 then epplp = substr (instruction_array (instruction), 19, 10) = "370"b3 || "0"b;
1216 end;
1217
1218 if epplp | ^use_lp
1219 then cost_or_time = cost_or_time - 1;
1220 end;
1221
1222 cost_or_time = cost_or_time * count;
1223 end;
1224
1225
1226
1227 value_array (value).count = count;
1228 value_array (value).cost_or_time = cost_or_time;
1229
1230 if long
1231 then value_array (value).page_faults = pf -> long_profile_entry.pf;
1232 else value_array (value).page_faults = 0;
1233
1234
1235
1236 total_count = total_count + count;
1237 total_cost_or_time = total_cost_or_time + cost_or_time;
1238
1239 if long
1240 then total_page_faults = total_page_faults + pf -> long_profile_entry.pf;
1241 end scan_statement_data;
1242 ^L
1243
1244
1245
1246
1247
1248 store_temp_data:
1249 procedure (from_ptr, n_words);
1250 declare from_ptr ptr;
1251 declare n_words fixed binary (19);
1252
1253 declare word_array (n_words) bit (36) aligned based;
1254
1255 if last_temp_data_word.offset + n_words >= sys_info$max_seg_size
1256 then do;
1257 call extend_temp_data_file;
1258 last_temp_data.component = pfd_file_control.last_component;
1259 last_temp_data.offset = 0;
1260 end;
1261 else do;
1262 last_temp_data.component = last_temp_data_word.component;
1263 last_temp_data.offset = last_temp_data_word.offset + 1;
1264 end;
1265
1266 ptr_from_msf_ptr (last_temp_data) -> word_array = from_ptr -> word_array;
1267
1268 last_temp_data_word.component = last_temp_data.component;
1269 last_temp_data_word.offset = last_temp_data.offset + n_words - 1;
1270 end store_temp_data;
1271
1272 end scan_component;
1273 ^L
1274
1275
1276 find_object:
1277 procedure (name, p, hp, bound_object_segment, code);
1278
1279 declare name char (*);
1280 declare p ptr;
1281 declare hp ptr;
1282 declare bound_object_segment bit (1);
1283 declare code fixed binary (35);
1284
1285 declare delim char (1);
1286
1287 bound_object_segment = "1"b;
1288
1289 if search (name, "<>") = 0
1290 then delim = "$";
1291 else delim = "|";
1292
1293 hp = cv_ptr_ (rtrim (name) || delim || "bind_map", code);
1294
1295 if code = 0
1296 then p = addrel (hp, hp -> std_symbol_header.next_block);
1297 else do;
1298 hp = cv_ptr_ (rtrim (name) || delim || "symbol_table", code);
1299 p = hp;
1300 bound_object_segment = "0"b;
1301 end;
1302 end find_object;
1303
1304
1305
1306 extend_temp_data_file:
1307 procedure;
1308
1309 if pfd_file_control.last_component >= hbound (pfd_file_control.component, 1)
1310 then call error (error_table_$file_is_full, "Temporary (internal) data.");
1311
1312
1313 pfd_file_control.last_component = pfd_file_control.last_component + 1;
1314 call get_temp_segment_ (me, pfd_file_control.component (pfd_file_control.last_component), code);
1315 call err_check;
1316 end extend_temp_data_file;
1317
1318 end scan_data;
1319 ^L
1320
1321
1322 store_output_file:
1323 procedure;
1324
1325 declare component fixed binary;
1326
1327 call expand_pathname_$add_suffix (output_file, profile_data_suffix, dirname, entryname, code);
1328 if code ^= 0
1329 then call error (code, output_file);
1330
1331 call msf_manager_$open (dirname, entryname, output_fcb, code);
1332 if output_fcb = null
1333 then call file_error;
1334
1335 do component = 0 to pfd_file_control.last_component - 1;
1336 call store_output_data (sys_info$max_seg_size);
1337 end;
1338
1339 call store_output_data (last_temp_data_word.offset + 1);
1340
1341 call msf_manager_$adjust (output_fcb, component, 36 * (last_temp_data_word.offset + 1), "111"b, code);
1342 if code ^= 0
1343 then call file_error;
1344
1345 call msf_manager_$close (output_fcb);
1346 output_fcb = null;
1347
1348 return;
1349
1350 store_output_data:
1351 procedure (n_words);
1352 declare n_words fixed binary (19);
1353
1354 declare output_ptr ptr;
1355
1356 declare word_array (n_words) bit (36) aligned based;
1357
1358 call msf_manager_$get_ptr (output_fcb, component, "1"b , output_ptr, (0), code);
1359 if output_ptr = null
1360 then call file_error;
1361
1362 output_ptr -> word_array = pfd_file_control.component (component) -> word_array;
1363 end store_output_data;
1364
1365 end store_output_file;
1366 ^L
1367
1368
1369 print_or_list:
1370 procedure (listing);
1371 declare listing bit (1);
1372
1373 declare date_time char (24);
1374 declare print_program bit (1);
1375 declare more_than_one_program bit (1);
1376 declare this_value fixed binary (18);
1377 declare threshold (4) fixed binary (35);
1378
1379 more_than_one_program = "0"b;
1380
1381
1382
1383 if args.input_file & ^args.no_header & ^listing
1384 then call output_header (iox_$user_output);
1385
1386
1387
1388 do program_ptr = ptr_from_msf_ptr (pfd_header.first_program) repeat ptr_from_msf_ptr (program.next_program)
1389 while (program_ptr ^= null);
1390
1391
1392
1393 if args.input_file & n_program_names > 0
1394 then do;
1395 do prog_nr = 1 to n_program_names while (get_program_name (prog_nr) ^= program.name);
1396 end;
1397 print_program = prog_nr <= n_program_names;
1398 end;
1399 else print_program = "1"b;
1400
1401 if print_program
1402 then if listing
1403 then call list_one_program;
1404 else call print_one_program;
1405 end;
1406
1407 return;
1408 ^L
1409
1410
1411 print_one_program:
1412 procedure;
1413
1414 declare skip bit (1);
1415 declare sort_array_ptr ptr;
1416
1417 declare sort_array (n_values) fixed binary (18) aligned based (sort_array_ptr);
1418
1419 call ioa_ ("^/Program: ^a", program.name);
1420
1421 if ^args.no_header
1422 then call ioa_ (" LINE STMT COUNT ^[TIME^;COST^] STARS^[ AVGTIME PGEFLTS^] OPERATORS",
1423 program.long_profile, program.long_profile);
1424
1425 operator_ptr = ptr_from_msf_ptr (program.operator_array);
1426 value_ptr = ptr_from_msf_ptr (program.value_array);
1427 n_values = program.n_values;
1428
1429
1430
1431 if args.sort
1432 then begin;
1433 declare disordered bit (1);
1434 declare sort_test fixed binary;
1435
1436 declare cost_or_time_test fixed binary internal static options (constant) initial (3);
1437 declare count_test fixed binary internal static options (constant) initial (1);
1438 declare page_faults_test fixed binary internal static options (constant) initial (2);
1439
1440 call get_seg (2, sort_array_ptr);
1441
1442 do value = 1 to n_values;
1443 sort_array (value) = value;
1444 end;
1445
1446
1447
1448 if sort_field (1)
1449 then sort_test = count_test;
1450
1451 else if (sort_field (4) | sort_field (5)) & program.long_profile
1452 then sort_test = page_faults_test;
1453
1454 else sort_test = cost_or_time_test;
1455
1456
1457
1458 interval = n_values;
1459 do while (interval > 1);
1460 interval = 2 * divide (interval, 4, 18) + 1;
1461 do i = 1 to n_values - interval;
1462 k = i + interval;
1463 comparing = "1"b;
1464 do while (comparing);
1465 comparing = "0"b;
1466 j = k - interval;
1467 goto case (sort_test);
1468
1469 case (1):
1470 disordered = value_array (sort_array (j)).count < value_array (sort_array (k)).count;
1471 goto end_case;
1472
1473 case (2):
1474 disordered =
1475 value_array (sort_array (j)).page_faults < value_array (sort_array (k)).page_faults;
1476 goto end_case;
1477
1478 case (3):
1479 disordered =
1480 value_array (sort_array (j)).cost_or_time < value_array (sort_array (k)).cost_or_time;
1481 goto end_case;
1482
1483 end_case:
1484 if disordered
1485 then do;
1486 value = sort_array (k);
1487 sort_array (k) = sort_array (j);
1488 sort_array (j) = value;
1489 if j > interval
1490 then do;
1491 comparing = "1"b;
1492 k = j;
1493 end;
1494 end;
1495 end;
1496 end;
1497 end;
1498 end;
1499
1500 call init_star_thresholds (program.total_cost_or_time);
1501
1502 exit = "0"b;
1503 do value = 1 to n_values while (^exit);
1504 skip = "0"b;
1505
1506
1507
1508 if args.sort
1509 then this_value = sort_array (value);
1510 else this_value = value;
1511
1512 if args.first
1513 then if value > first
1514 then exit = "1"b;
1515
1516 if (args.to | args.from) & value_array (value).file ^= 0
1517 then exit = "1"b;
1518
1519 if args.to
1520 then if value_array (value).line > to
1521 then exit = "1"b;
1522
1523 if args.from
1524 then if value_array (value).line < from
1525 then skip = "1"b;
1526
1527 if args.brief & value_array (this_value).count = 0
1528 then skip = "1"b;
1529
1530 if ^exit & ^skip
1531 then begin;
1532 declare average_time fixed binary (35);
1533 declare operator_name char (32) aligned;
1534
1535
1536
1537 if program.long_profile & value_array (this_value).count ^= 0
1538 then average_time =
1539 float (value_array (this_value).cost_or_time) / float (value_array (this_value).count)
1540 + 0.5;
1541 else average_time = 0;
1542
1543 line_buffer = "";
1544 do i = value_array (this_value).first_operator
1545 to value_array (this_value).first_operator + value_array (this_value).n_operators - 1;
1546 call find_operator_name_ (program.translator, addr (operator_array (i)), operator_name);
1547
1548 if operator_name ^= "" & line_buffer ^= ""
1549 then line_buffer = line_buffer || ", ";
1550
1551 line_buffer = line_buffer || rtrim (operator_name);
1552 end;
1553
1554 call ioa_
1555 (
1556 "^[^s^6d ^;^d-^d^8t^]^[^4d^;^s^4x^] ^7d ^9d ^4a ^[^[^7d^;^s^7x^] ^[^8d^;^s^8x^] ^;^4s^]^a",
1557 value_array (this_value).file = 0, value_array (this_value).file, value_array (this_value).line,
1558 value_array (this_value).statement ^= 1, value_array (this_value).statement,
1559 value_array (this_value).count, value_array (this_value).cost_or_time, stars (),
1560 program.long_profile, average_time ^= 0, average_time,
1561 value_array (this_value).page_faults ^= 0, value_array (this_value).page_faults, line_buffer);
1562 end;
1563 end;
1564
1565
1566
1567 call ioa_ ("
1568 call ioa_ ("Totals: ^11d ^9d^[ ^24d^]", program.total_count, program.total_cost_or_time, program.long_profile,
1569 program.total_page_faults);
1570 end print_one_program;
1571 ^L
1572
1573
1574 list_one_program:
1575 procedure;
1576
1577 declare source_length fixed binary (21);
1578
1579
1580
1581 call open_file (0);
1582
1583
1584
1585 if list_iocb = null
1586 then begin;
1587 declare list_file char (32);
1588
1589 if n_program_names = 0
1590 then list_file = rtrim (program.name) || "." || profile_listing_suffix;
1591 else list_file = rtrim (get_program_name (1)) || "." || profile_listing_suffix;
1592
1593 call iox_$attach_name (me || "." || unique_chars_ (""b), list_iocb, "vfile_ " || list_file,
1594 codeptr (list_one_program), code);
1595 if code = 0
1596 then call iox_$open (list_iocb, Stream_output, "0"b, code);
1597
1598 if code ^= 0
1599 then call error (code, list_file);
1600 end;
1601
1602
1603
1604 if more_than_one_program
1605 then call ioa_$ioa_switch (list_iocb, "^|");
1606 else more_than_one_program = "1"b;
1607
1608 call ioa_$ioa_switch_nnl (list_iocb, "Profile listing of ^a>^a", dirname, entryname);
1609 if args.input_file
1610 then do;
1611 call expand_pathname_$add_suffix (input_file, profile_data_suffix, dirname, entryname, code);
1612 call err_check;
1613 call output_header (list_iocb);
1614 end;
1615 else call ioa_$ioa_switch (list_iocb, "");
1616
1617 call date_time_ (clock (), date_time);
1618 call ioa_$ioa_switch (list_iocb, "Date: ^a", date_time);
1619 call ioa_$ioa_switch (list_iocb, "Total count: ^d Total ^[time: ^d Total page faults: ^d^;cost: ^d^s^]",
1620 program.total_count, program.long_profile, program.total_cost_or_time, program.total_page_faults);
1621
1622
1623
1624 call init_star_thresholds (program.total_cost_or_time);
1625
1626 value_ptr = ptr_from_msf_ptr (program.value_array);
1627 n_values = program.n_values;
1628 this_value = 1;
1629
1630 call list_file (0);
1631 do while (this_value <= n_values);
1632 call open_file (value_array (this_value).file);
1633 call ioa_$ioa_switch (list_iocb, "^/Include file ^d: ^a>^a", value_array (this_value).file, dirname, entryname)
1634 ;
1635
1636 call list_file (value_array (this_value).file);
1637 end;
1638
1639 return;
1640 ^L
1641
1642
1643 open_file:
1644 procedure (file);
1645 declare file fixed binary (10) unsigned unaligned;
1646
1647
1648 declare source_bc fixed binary (24);
1649
1650 source_path_ptr = ptr_from_msf_ptr (program.source_path_array);
1651 call expand_pathname_ (source_path_array (file), dirname, entryname, code);
1652 if code ^= 0
1653 then call error (code, source_path_array (file));
1654
1655
1656
1657 if args.source_dir
1658 then dirname = source_dir;
1659
1660 call hcs_$initiate_count (dirname, entryname, "", source_bc, 0, source_ptr, code);
1661 if source_ptr = null & (file = 0 | ^args.source_dir)
1662 then call file_error;
1663
1664
1665
1666 if source_ptr = null
1667 then do;
1668 call expand_pathname_ (source_path_array (file), dirname, entryname, code);
1669 call err_check;
1670
1671 call hcs_$initiate_count (dirname, entryname, "", source_bc, 0, source_ptr, code);
1672 if source_ptr = null
1673 then do;
1674 dirname = source_dir;
1675 call file_error;
1676 end;
1677 end;
1678
1679 source_length = divide (source_bc + 8, 9, 21);
1680 if source_length = 0
1681 then do;
1682 code = error_table_$zero_length_seg;
1683 call file_error;
1684 end;
1685 end open_file;
1686 ^L
1687
1688
1689 list_file:
1690 procedure (file);
1691 declare file fixed binary (10) unsigned unaligned;
1692
1693
1694 declare column fixed binary;
1695 declare continuation_line bit (1);
1696 declare line fixed binary (21);
1697 declare scan_length fixed binary (21);
1698 declare source_position fixed binary (21);
1699 declare tab_column fixed binary;
1700
1701 declare source char (source_length) based (source_ptr);
1702
1703
1704
1705 call ioa_$ioa_switch (list_iocb, "^/ COUNT ^[TIME STARS P ^;COST STARS^] LINE SOURCE", program.long_profile);
1706
1707
1708
1709 call initialize_line;
1710
1711 line = 1;
1712 source_position = 1;
1713 do while (source_position <= length (source));
1714 scan_length = search (substr (source, source_position), HT_NL) - 1;
1715 if scan_length < 0
1716 then scan_length = length (substr (source, source_position));
1717
1718 begin;
1719 declare chars char (scan_length) defined (source) position (source_position);
1720
1721 call put_chars (chars);
1722 end;
1723
1724 if source_position + scan_length <= length (source)
1725 then if substr (source, source_position + scan_length, 1) = HT
1726 then begin;
1727 declare SP10 char (10) internal static options (constant) initial ("");
1728 declare spaces_to_tab_stop char (10 - mod (tab_column - 1, 10)) defined (SP10);
1729
1730 call put_chars (spaces_to_tab_stop);
1731 end;
1732
1733 else call put_nl;
1734
1735 source_position = source_position + scan_length + 1;
1736 end;
1737
1738
1739
1740 if index (reverse (source), NL) ^= 1
1741 then call put_nl;
1742
1743
1744
1745 call put_profile_data ("0"b);
1746
1747
1748
1749 call hcs_$terminate_noname (source_ptr, code);
1750 source_ptr = null;
1751 call err_check;
1752
1753 return;
1754 ^L
1755
1756
1757 put_chars:
1758 procedure (chars);
1759 declare chars char (*);
1760
1761 declare chars_to_store fixed binary (21);
1762 declare start_position fixed binary (21);
1763
1764 start_position = 1;
1765 do while (start_position <= length (chars));
1766 call put_profile_data ("1"b);
1767
1768 chars_to_store = min (length (substr (chars, start_position)), line_length - column + 1);
1769 line_buffer = line_buffer || substr (chars, start_position, chars_to_store);
1770
1771 start_position = start_position + chars_to_store;
1772 column = column + chars_to_store;
1773 tab_column = tab_column + chars_to_store;
1774
1775 if column > line_length
1776 then call put_line;
1777 end;
1778 end put_chars;
1779
1780
1781
1782 put_nl:
1783 procedure;
1784
1785 call put_profile_data ("1"b);
1786 call put_line;
1787 call initialize_line;
1788 line = line + 1;
1789 end put_nl;
1790 ^L
1791
1792
1793 put_profile_data:
1794 procedure (more_source_characters);
1795 declare more_source_characters bit (1) aligned;
1796
1797 declare previous_line_profile_data
1798 bit (1) aligned;
1799 declare this_line_profile_data bit (1) aligned;
1800
1801 do while (column = 1);
1802 previous_line_profile_data = "0"b;
1803 this_line_profile_data = "0"b;
1804
1805 if this_value <= n_values
1806 then if value_array (this_value).line < line & value_array (this_value).file = file
1807 then previous_line_profile_data = "1"b;
1808
1809 else if value_array (this_value).line = line & value_array (this_value).file = file
1810 then this_line_profile_data = "1"b;
1811
1812 if previous_line_profile_data | this_line_profile_data
1813 then do;
1814 call ioa_$ioa_switch_nnl (list_iocb,
1815 "^[^7d^;^7x^s^] ^[^8d^;^8x^s^] ^4a ^[^[^2d^;^2x^s^] ^;^2s^]^[^5d^;^5x^s^]^[^/^; ^]",
1816 value_array (this_value).count ^= 0, value_array (this_value).count,
1817 value_array (this_value).cost_or_time ^= 0, value_array (this_value).cost_or_time, stars (),
1818 program.long_profile, value_array (this_value).page_faults ^= 0,
1819 value_array (this_value).page_faults, ^continuation_line & this_line_profile_data, line,
1820 previous_line_profile_data);
1821
1822 this_value = this_value + 1;
1823 end;
1824
1825 else if more_source_characters
1826 then call ioa_$ioa_switch_nnl (list_iocb, "^22x^[^3x^]^[^5d^;^5x^s^] ", program.long_profile,
1827 ^continuation_line, line);
1828
1829 if ^previous_line_profile_data
1830 then do;
1831 continuation_line = "1"b;
1832
1833 if program.long_profile
1834 then column = 32;
1835 else column = 29;
1836 end;
1837 end;
1838 end put_profile_data;
1839 ^L
1840
1841
1842 initialize_line:
1843 procedure;
1844
1845 column = 1;
1846 tab_column = 1;
1847 line_buffer = "";
1848 continuation_line = "0"b;
1849 end initialize_line;
1850
1851
1852
1853 put_line:
1854 procedure;
1855
1856 line_buffer = line_buffer || NL;
1857
1858 call iox_$put_chars (list_iocb, addrel (addr (line_buffer), 1), length (line_buffer), code);
1859 call err_check;
1860
1861 line_buffer = "";
1862 column = 1;
1863 end put_line;
1864
1865 end list_file;
1866
1867 end list_one_program;
1868 ^L
1869
1870
1871 output_header:
1872 procedure (iocb);
1873 declare iocb ptr;
1874
1875 call ioa_$ioa_switch (iocb, "^/Profile data file ^a>^a", dirname, entryname);
1876 call date_time_ (pfd_header.date_time_stored, date_time);
1877 call ioa_$ioa_switch (iocb, "Created by ^a on ^a", pfd_header.person_project, date_time);
1878
1879 if pfd_header.comment ^= ""
1880 then call ioa_$ioa_switch (iocb, "Comment: ^a", pfd_header.comment);
1881 end output_header;
1882
1883
1884
1885
1886
1887
1888
1889
1890 init_star_thresholds:
1891 procedure (total_cost_or_time);
1892 declare total_cost_or_time fixed binary (35);
1893
1894 threshold (1) = divide (total_cost_or_time, 40, 35) + 1;
1895 threshold (2) = divide (total_cost_or_time, 20, 35) + 1;
1896 threshold (3) = divide (total_cost_or_time, 10, 35) + 1;
1897 threshold (4) = divide (total_cost_or_time, 5, 35) + 1;
1898 end init_star_thresholds;
1899
1900
1901
1902 stars:
1903 procedure returns (char (4));
1904
1905 declare n fixed binary (35);
1906
1907 n = value_array (this_value).cost_or_time;
1908 if value_array (this_value).count = 0
1909 then return (".");
1910
1911 else if n < threshold (1)
1912 then return ("");
1913
1914 else if n < threshold (2)
1915 then return ("*");
1916
1917 else if n < threshold (3)
1918 then return ("**");
1919
1920 else if n < threshold (4)
1921 then return ("***");
1922
1923 else return ("****");
1924 end stars;
1925
1926 end print_or_list;
1927 ^L
1928
1929
1930 plot:
1931 procedure;
1932
1933 declare plot_program bit (1);
1934
1935
1936
1937 do program_ptr = ptr_from_msf_ptr (pfd_header.first_program) repeat ptr_from_msf_ptr (program.next_program)
1938 while (program_ptr ^= null);
1939
1940
1941
1942 if args.input_file & n_program_names > 0
1943 then do;
1944 do prog_nr = 1 to n_program_names while (get_program_name (prog_nr) ^= program.name);
1945 end;
1946 plot_program = prog_nr <= n_program_names;
1947 end;
1948 else plot_program = "1"b;
1949
1950 if plot_program
1951 then call plot_one_program;
1952 end;
1953
1954 return;
1955 ^L
1956
1957
1958 plot_one_program:
1959 procedure;
1960
1961 declare plot_array_ptr ptr;
1962 declare skip bit (1);
1963 declare x_array_ptr ptr;
1964 declare y_array_ptr ptr;
1965
1966 declare 1 plot_array (divide (sys_info$max_seg_size, 2, 19)) aligned based (plot_array_ptr),
1967 2 line float binary,
1968 2 data float binary;
1969 declare x_array (2 * n_values + 2) float binary based (x_array_ptr);
1970 declare y_array (2 * n_values + 2) float binary based (y_array_ptr);
1971
1972 call get_seg (1, plot_array_ptr);
1973 call get_seg (2, x_array_ptr);
1974 call get_seg (3, y_array_ptr);
1975
1976 value_ptr = ptr_from_msf_ptr (program.value_array);
1977
1978
1979
1980 n_values = 0;
1981 exit = "0"b;
1982 do value = 1 to program.n_values while (^exit);
1983 skip = "0"b;
1984
1985
1986
1987 if value_array (value).file ^= 0
1988 then exit = "1"b;
1989
1990 if args.to
1991 then if value_array (value).line > to
1992 then exit = "1"b;
1993
1994 if args.from
1995 then if value_array (value).line < from
1996 then skip = "1"b;
1997
1998 if ^exit & ^skip
1999 then do;
2000
2001
2002
2003 if n_values ^= 0
2004 then do while (value_array (value).line > plot_array (n_values).line + 1);
2005 n_values = n_values + 1;
2006 plot_array (n_values).line = plot_array (n_values - 1).line + 1.0;
2007 plot_array (n_values).data = 0.0;
2008 end;
2009
2010
2011
2012 n_values = n_values + 1;
2013 plot_array (n_values).line = float (value_array (value).line);
2014
2015 if plot_field (1)
2016 then plot_array (n_values).data = float (value_array (value).count);
2017
2018 else if (plot_field (4) | plot_field (5)) & program.long_profile
2019 then plot_array (n_values).data = float (value_array (value).page_faults);
2020
2021 else plot_array (n_values).data = float (value_array (value).cost_or_time);
2022 end;
2023 end;
2024
2025 if n_values = 0
2026 then do;
2027 n_values = 1;
2028 plot_array (1).line = 0.0;
2029 plot_array (1).data = 0.0;
2030 end;
2031
2032
2033
2034
2035
2036
2037
2038 if n_values > max_points
2039 then begin;
2040 declare c float binary;
2041 declare c1 float binary;
2042
2043 c = 1.0 - (max_points - 1) / n_values;
2044 c1 = c;
2045 i = 1;
2046 do value = 2 to n_values;
2047 c1 = c1 + c;
2048
2049 if c1 >= 1.0
2050 then do;
2051 c1 = c1 - 1.0;
2052 plot_array (i).data = plot_array (i).data + plot_array (value).data;
2053
2054 end;
2055 else do;
2056 i = i + 1;
2057 plot_array (i) = plot_array (value);
2058 end;
2059 end;
2060 n_values = i;
2061 end;
2062
2063
2064
2065
2066 i = 1;
2067 do value = 2 to n_values;
2068 if plot_array (value).line = plot_array (i).line
2069 then plot_array (i).data = plot_array (i).data + plot_array (value).data;
2070
2071
2072 else if plot_array (i).data ^= plot_array (value).data | value = n_values
2073
2074 then do;
2075 i = i + 1;
2076 plot_array (i) = plot_array (value);
2077 end;
2078 end;
2079 n_values = i;
2080
2081
2082
2083
2084
2085
2086 y_array (1) = 0.0;
2087 do value = 1 to n_values;
2088 i = 2 * value - 1;
2089 x_array (i), x_array (i + 1) = plot_array (value).line - 0.5;
2090 y_array (i + 1), y_array (i + 2) = plot_array (value).data;
2091 end;
2092
2093 i = 2 * n_values + 1;
2094 x_array (i), x_array (i + 1) = plot_array (n_values).line + 0.5;
2095 y_array (i + 1) = 0.0;
2096
2097
2098
2099 line_buffer = "Program: " || rtrim (program.name);
2100
2101 if pfd_header.comment ^= ""
2102 then line_buffer = line_buffer || " (" || rtrim (pfd_header.comment) || ")";
2103
2104 call plot_$setup ((line_buffer), "LINE NUMBER" , table_1_upper_case (y_legend), Linear_linear, 0.0,
2105 Tick_marks, Normal_scaling);
2106 call plot_ (x_array, y_array, hbound (x_array, 1), Vectors_only, "");
2107 end plot_one_program;
2108
2109 end plot;
2110 ^L
2111
2112
2113 get_seg:
2114 procedure (number, target);
2115 declare number fixed binary;
2116 declare target ptr;
2117
2118 if temp_seg_array (number) = null
2119 then do;
2120 call get_temp_segment_ (me, temp_seg_array (number), code);
2121 call err_check;
2122 end;
2123
2124 target = temp_seg_array (number);
2125 end get_seg;
2126
2127
2128
2129 get_program_name:
2130 procedure (program_index) returns (char (32));
2131 declare program_index fixed binary;
2132
2133 declare entryname char (32);
2134
2135 call cu_$arg_ptr (program_name_array (program_index), arg_ptr, arg_len, code);
2136 call err_check;
2137
2138 call expand_pathname_ (arg, "", entryname, code);
2139 if code ^= 0
2140 then call error (code, arg);
2141
2142 return (entryname);
2143 end get_program_name;
2144
2145
2146
2147 ptr_from_msf_ptr:
2148 procedure (msf_ptr) returns (ptr);
2149 declare 1 msf_ptr aligned like msf_ptr_template;
2150
2151 if unspec (msf_ptr) = unspec (null_msf_ptr)
2152 then return (null);
2153 else return (ptr (pfd_file_control.component (msf_ptr.component), msf_ptr.offset));
2154 end ptr_from_msf_ptr;
2155
2156 end profile;