/* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* The profile command, main section. Acquires, stores, prints, lists, plots, and resets program execution performance data. Last Modified: 14 May 1979 by D. Spector: completely rewritten to include new features. August 1979 by RE Mullen: bug fixes and performance improvements. 12-Sep-79 by M. N. Davidoff: bug fixes, some clean up, added include file profile data reporting. 1982, CAH, bug fix to long_profile with seperate static. Algorithm is as follows: 1. Get arguments. 2. If -input_file specified, then use given file, else construct data in temp segs from current (internal static) data. 3. If -output_file specified, then copy temp segs to given file. 4. If -list specified, generate listing. 5. If -plot specified, plot profile. 6. If -print specified or implied, print profile data. 7. If -reset specified, reset current (internal static) data. Profile data exists in three separate formats: 1. Current (internal static) data. Stored in active linkage section. 2. Temporary data used for sorting and passing to display subroutines. Stored in temp segs using permanent data format. See pfd_format.incl.pl1. 3. Permanent data (pfd file). See pfd_format.incl.pl1. */ profile: pf: procedure; /* automatic */ declare arg_len fixed binary (21); declare arg_ptr ptr; declare 1 args, /* Flags for control args */ 2 brief bit (1), 2 comment bit (1), 2 exclude bit (1), /* Not implemented */ 2 first bit (1), 2 from bit (1), 2 hardcore bit (1), 2 input_file bit (1), 2 last bit (1), /* Not implemented */ 2 line_length bit (1), 2 list bit (1), 2 long bit (1), 2 max_points bit (1), 2 no_header bit (1), 2 output_file bit (1), 2 plot bit (1), 2 print bit (1), 2 reset bit (1), 2 search_dir bit (1), 2 sort bit (1), 2 source_dir bit (1), 2 to bit (1); declare code fixed binary (35); declare comment char (128); declare comparing bit (1); declare dirname char (168); declare entryname char (32); declare exclude_fields (5) bit (1); /* Not implemented */ declare exit bit (1); declare first fixed binary (35); declare from fixed binary (35); declare i fixed binary (18); declare input_file char (168); declare interval fixed binary (18); declare j fixed binary (18); declare k fixed binary (18); declare 1 last_temp_data_word aligned like msf_ptr_template; declare line_buffer char (1200) varying; declare line_length fixed binary (35); declare list_iocb ptr; declare max_points fixed binary (35); declare n_program_names fixed binary; declare n_search_paths fixed binary; declare n_values fixed binary (18); declare output_fcb ptr; declare output_file char (168); declare 1 pfd_file_control aligned, 2 fcb ptr, /* File control block for msf_manager_ */ 2 last_component fixed binary, 2 component (0:9) ptr; /* Pointers to MSF components */ declare plot_field (5) bit (1); declare prog_nr fixed binary; declare program_name_array (100) fixed binary; declare search_path (8) char (168); declare sort_field (5) bit (1); declare source_dir char (168); declare source_ptr ptr; declare temp_seg_array (3) ptr; declare to fixed binary (35); declare value fixed binary (18); declare y_legend fixed binary; /* based */ declare arg char (arg_len) based (arg_ptr); /* builtin */ declare addr builtin; declare addrel builtin; declare baseno builtin; declare bin builtin; declare clock builtin; declare codeptr builtin; declare divide builtin; declare float builtin; declare hbound builtin; declare index builtin; declare length builtin; declare min builtin; declare mod builtin; declare null builtin; declare ptr builtin; declare reverse builtin; declare rtrim builtin; declare search builtin; declare size builtin; declare stackbaseptr builtin; declare string builtin; declare substr builtin; declare unspec builtin; /* condition */ declare cleanup condition; /* internal static */ declare HT char (1) internal static options (constant) initial (" "); declare HT_NL char (2) internal static options (constant) initial (" "); declare NL char (1) internal static options (constant) initial (" "); declare me char (7) internal static options (constant) initial ("profile"); declare profile_data_suffix char (3) internal static options (constant) initial ("pfd"); declare profile_listing_suffix char (3) internal static options (constant) initial ("pfl"); declare table_1 (5) char (12) internal static options (constant) initial ("count", "cost", "time", "page_faults", "pfs"); declare table_1_upper_case (5) char (12) internal static options (constant) initial ("COUNT", "COST", "TIME", "PAGE FAULTS", "PAGE FAULTS"); /* external static */ declare error_table_$badopt fixed binary (35) external static; declare error_table_$bigarg fixed binary (35) external static; declare error_table_$file_is_full fixed binary (35) external static; declare error_table_$improper_data_format fixed binary (35) external static; declare error_table_$inconsistent fixed binary (35) external static; declare error_table_$name_not_found fixed binary (35) external static; declare error_table_$noarg fixed binary (35) external static; declare error_table_$noentry fixed binary (35) external static; declare error_table_$too_many_args fixed binary (35) external static; declare error_table_$zero_length_seg fixed binary (35) external static; declare iox_$user_output ptr external static; declare sys_info$max_seg_size fixed binary (19) external static; /* entry */ declare absolute_pathname_ entry (char (*), char (*), fixed binary (35)); declare com_err_ entry options (variable); declare com_err_$suppress_name entry options (variable); declare cu_$arg_count entry (fixed binary); declare cu_$arg_ptr entry (fixed binary, ptr, fixed binary (21), fixed binary (35)); declare cv_dec_check_ entry (char (*), fixed binary (35)) returns (fixed binary (35)); declare cv_ptr_ entry (char (*), fixed binary (35)) returns (ptr); declare date_time_ entry (fixed binary (71), char (*)); declare expand_pathname_ entry (char (*), char (*), char (*), fixed binary (35)); declare expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed binary (35)); declare find_operator_name_ entry (char (*), ptr, char (32) aligned); declare get_group_id_ entry () returns (char (32)); declare get_temp_segment_ entry (char (*), ptr, fixed binary (35)); declare hcs_$initiate_count entry (char (*), char (*), char (*), fixed binary (24), fixed binary (2), ptr, fixed binary (35)); declare hcs_$terminate_noname entry (ptr, fixed binary (35)); declare ioa_ entry options (variable); declare ioa_$ioa_switch entry options (variable); declare ioa_$ioa_switch_nnl entry options (variable); declare iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed binary (35)); declare iox_$close entry (ptr, fixed binary (35)); declare iox_$detach_iocb entry (ptr, fixed binary (35)); declare iox_$open entry (ptr, fixed binary, bit (1) aligned, fixed binary (35)); declare iox_$put_chars entry (ptr, ptr, fixed binary (21), fixed binary (35)); declare msf_manager_$adjust entry (ptr, fixed binary, fixed binary (24), bit (3), fixed binary (35)); declare msf_manager_$close entry (ptr); declare msf_manager_$get_ptr entry (ptr, fixed binary, bit (1), ptr, fixed binary (24), fixed binary (35)); declare msf_manager_$open entry (char (*), char (*), ptr, fixed binary (35)); declare release_temp_segments_ entry (char (*), (*) ptr, fixed binary (35)); declare ring0_get_$name entry (char (*), char (*), ptr, fixed binary (35)); declare ring0_get_$segptr entry (char (*), char (*), ptr, fixed binary (35)); declare ring_zero_peek_ entry (ptr, ptr, fixed binary (18), fixed binary (35)); declare unique_chars_ entry (bit (*)) returns (char (15)); %include pfd_format; %include lot; %include linkdcl; %include stack_header; %include std_symbol_header; /* Non-standard object segment symbol block format */ %include symbol_header; %include pl1_symbol_block; %include source_map; %include statement_map; %include profile_entry; %include long_profile; %include plot_entry_dcls; %include iox_modes; /* Start of command */ call initialize; on cleanup call clean; call get_arguments; /* Process -input_file */ if args.input_file then call open_input_file; else call scan_data ("1"b); /* Process -output_file */ if args.output_file then call store_output_file; /* Process display options */ if args.list then call print_or_list ("1"b); if args.plot then call plot; if args.print then call print_or_list ("0"b); /* Process -reset */ if args.reset then call scan_data ("0"b); /* Done */ quit: call clean; return; /* Error handling subroutines */ err_check: procedure; if code ^= 0 then call error (code, ""); end err_check; error: procedure (code, text); declare code fixed binary (35); /* (Input) */ declare text char (*); /* (Input) */ call com_err_ (code, me, "^a", text); goto quit; end error; file_error: procedure; call com_err_ (code, me, "^a>^a", dirname, entryname); goto quit; end file_error; /* Initialization */ initialize: procedure; /* Initialize cleanup handling */ temp_seg_array (*) = null; pfd_file_control.component (*) = null; pfd_file_control.fcb = null; output_fcb = null; source_ptr = null; list_iocb = null; /* Other initialization */ n_search_paths = 0; n_program_names = 0; string (args) = ""b; end initialize; /* Free temporary storage at end and upon QUIT/release */ clean: procedure; call release_temp_segments_ (me, temp_seg_array, code); call release_temp_segments_ (me, pfd_file_control.component, code); if pfd_file_control.fcb ^= null then do; call msf_manager_$close (pfd_file_control.fcb); pfd_file_control.fcb = null; end; if output_fcb ^= null then do; call msf_manager_$adjust (output_fcb, 0, 0, "111"b, code); call msf_manager_$close (output_fcb); output_fcb = null; end; if source_ptr ^= null then do; call hcs_$terminate_noname (source_ptr, code); source_ptr = null; end; if list_iocb ^= null then do; call iox_$close (list_iocb, code); call iox_$detach_iocb (list_iocb, code); list_iocb = null; end; end clean; /* Get arguments */ get_arguments: procedure; declare arg_nr fixed binary; declare n_args fixed binary; declare operand_len fixed binary (21); declare operand_ptr ptr; declare operand char (operand_len) based (operand_ptr); call cu_$arg_count (n_args); do arg_nr = 1 to n_args; call cu_$arg_ptr (arg_nr, arg_ptr, arg_len, code); call err_check; if index (arg, "-") = 1 then if arg = "-pr" | arg = "-print" then args.print = "1"b; else if arg = "-nhe" | arg = "-no_header" then args.no_header = "1"b; else if arg = "-sort" then call accept_field (args.sort, sort_field, "0"b, table_1, (0)); else if arg = "-ft" | arg = "-first" then call accept_number (args.first, first, "first"); else if arg = "-lg" | arg = "-long" then do; args.brief = "0"b; args.long = "1"b; end; else if arg = "-ls" | arg = "-list" then args.list = "1"b; else if arg = "-scd" | arg = "-source_dir" then call accept_pathname (args.source_dir, source_dir); else if arg = "-ll" | arg = "-line_length" then call accept_number (args.line_length, line_length, "line_length"); else if arg = "-plot" then call accept_field (args.plot, plot_field, "0"b, table_1, y_legend); else if arg = "-fm" | arg = "-from" then call accept_number (args.from, from, "from"); else if arg = "-to" then call accept_number (args.to, to, "to"); else if arg = "-mp" | arg = "-max_points" then call accept_number (args.max_points, max_points, "max_points"); else if arg = "-of" | arg = "-output_file" then call accept_pathname (args.output_file, output_file); else if arg = "-com" | arg = "-comment" then call accept_string (args.comment, comment); else if arg = "-if" | arg = "-input_file" then call accept_pathname (args.input_file, input_file); else if arg = "-rs" | arg = "-reset" then args.reset = "1"b; else if arg = "-hard" | arg = "-hardcore" then args.hardcore = "1"b; else if arg = "-srhd" | arg = "-search_dir" then call accept_search_path; else if arg = "-bf" | arg = "-brief" then do; args.brief = "1"b; args.long = "0"b; end; else call error (error_table_$badopt, arg); /* Arguments (program names) */ else do; if search (arg, "$|") ^= 0 then call error (0, "Invalid program name. " || arg); if n_program_names >= hbound (program_name_array, 1) then call error (error_table_$too_many_args, "Program names."); n_program_names = n_program_names + 1; program_name_array (n_program_names) = arg_nr; end; end; /* Apply defaults */ if ^args.line_length then line_length = 132; /* Default printer width */ if ^args.max_points then max_points = 250; /* Default graphics resolution */ if args.hardcore & ^args.search_dir then do; n_search_paths = 1; search_path (1) = ">ldd>hard>o"; end; if ^args.list & ^args.plot & ^args.output_file & ^args.reset then args.print = "1"b; if args.print & ^args.long then args.brief = "1"b; /* Consistency checking */ if n_program_names = 0 & ^args.input_file then do; call com_err_$suppress_name (0, me, "Usage: ^a {program_names} {-control_args}", me); goto quit; end; if args.sort & ^args.print then call missing ("sort", "print"); if args.first & ^args.sort then call missing ("first", "sort"); if args.no_header & ^args.print then call missing ("no_header", "print"); if args.brief & ^args.print then call missing ("brief", "print"); if args.long & ^args.print then call missing ("long", "print"); if args.line_length & ^args.list then call missing ("line_length", "list"); if line_length < 50 then call error (error_table_$improper_data_format, "Line length too small."); if args.from & ^args.print & ^args.plot then call missing ("from", "print or -plot"); if args.to & ^args.print & ^args.plot then call missing ("to", "print or -plot"); if args.comment & ^args.output_file & ^args.plot then call missing ("comment", "output_file or -plot"); if args.max_points & ^args.plot then call missing ("max_points", "plot"); if args.search_dir & ^args.hardcore then call missing ("search_dir", "hardcore"); if args.source_dir & ^args.list then call missing ("source_dir", "list"); if args.reset & args.input_file then call error (error_table_$inconsistent, "-reset and -input_file"); if args.reset & args.hardcore then call error (error_table_$inconsistent, "-reset and -hardcore"); if args.output_file & args.input_file then call error (error_table_$inconsistent, "-input_file and -output_file"); if args.comment & args.input_file then call error (error_table_$inconsistent, "-comment and -input_file"); if args.hardcore & args.input_file then call error (error_table_$inconsistent, "-hardcore and -input_file"); if args.sort & args.to then call error (error_table_$inconsistent, "-sort and -to"); if args.sort & args.from then call error (error_table_$inconsistent, "-sort and -from"); return; /* Argument handling */ accept_number: procedure (arg_flag, value, text); declare arg_flag bit (1); /* (Output) */ declare value fixed binary (35); /* (Output) */ declare text char (*); /* (Input) */ call get_next_arg; value = cv_dec_check_ (operand, code); if code ^= 0 | value < 0 then call error (error_table_$improper_data_format, "After -" || text || ". " || operand); arg_flag = "1"b; end accept_number; accept_string: procedure (arg_flag, value); declare arg_flag bit (1); /* (Output) */ declare value char (*); /* (Output) */ call get_next_arg; if length (operand) > length (value) then call error (error_table_$bigarg, operand); value = operand; arg_flag = "1"b; end accept_string; accept_pathname: procedure (arg_flag, value); declare arg_flag bit (1); /* (Output) */ declare value char (*); /* (Output) */ call get_next_arg; call absolute_pathname_ (operand, value, code); if code ^= 0 then call error (code, operand); arg_flag = "1"b; end accept_pathname; accept_field: procedure (arg_flag, value, inclusive, table, subscript); declare arg_flag bit (1); /* (Output) */ declare value (*) bit (1); /* (Input/Output) */ declare inclusive bit (1); /* (Input) */ declare table (*) char (*); /* (Input) */ declare subscript fixed binary; /* (Output) */ call get_next_arg; do i = 1 to hbound (table, 1) while (table (i) ^= operand); end; if i > hbound (table, 1) then call error (0, "Invalid field name. " || operand); if ^arg_flag | ^inclusive then value (*) = "0"b; /* Clear value if first field specified or non-inclusive field */ value (i) = "1"b; subscript = i; arg_flag = "1"b; end accept_field; accept_search_path: procedure; if n_search_paths >= hbound (search_path, 1) then call error (error_table_$too_many_args, "Search paths."); n_search_paths = n_search_paths + 1; call accept_pathname (args.search_dir, search_path (n_search_paths)); end accept_search_path; get_next_arg: procedure; arg_nr = arg_nr + 1; if arg_nr > n_args then call error (error_table_$noarg, "Value for " || arg || "."); call cu_$arg_ptr (arg_nr, operand_ptr, operand_len, code); call err_check; end get_next_arg; missing: procedure (dependent_arg, main_arg); declare dependent_arg char (*); /* (Input) */ declare main_arg char (*); /* (Input) */ call com_err_ (0, me, "Invalid specification of -^a without -^a.", dependent_arg, main_arg); goto quit; end missing; end get_arguments; /* Open input profile data file */ open_input_file: procedure; declare arg_program_name char (32); call expand_pathname_$add_suffix (input_file, profile_data_suffix, dirname, entryname, code); if code ^= 0 then call error (code, input_file); call msf_manager_$open (dirname, entryname, pfd_file_control.fcb, code); if pfd_file_control.fcb = null | code = error_table_$noentry then call file_error; exit = "0"b; do i = 0 to hbound (pfd_file_control.component, 1) while (^exit); call msf_manager_$get_ptr (pfd_file_control.fcb, (i), "0"b /* Do not create */, pfd_file_control.component (i), (0), code); if pfd_file_control.component (i) = null /* No more components */ then exit = "1"b; end; /* Validate pfd data */ pfd_ptr = pfd_file_control.component (0); if pfd_header.version ^= pfd_format_version_1 then do; code = error_table_$improper_data_format; call file_error; end; /* Make sure all requested programs are in the profile data file. */ do prog_nr = 1 to n_program_names; arg_program_name = get_program_name (prog_nr); exit = "0"b; do program_ptr = ptr_from_msf_ptr (pfd_header.first_program) repeat ptr_from_msf_ptr (program.next_program) while (program_ptr ^= null & ^exit); exit = arg_program_name = program.name; end; if ^exit then call error (0, "Program not in profile data file. " || rtrim (arg_program_name) || " not in " || rtrim (dirname) || ">" || rtrim (entryname)); end; end open_input_file; /* Scan the current (internal static) profile data in order to construct temporary data in pf format or in order to reset it (see beginning for a discussion of the various data formats used) */ scan_data: procedure (constructing); declare constructing bit (1); /* (Input) "0"b: resetting, "1"b: constructing data */ declare another_component bit (1); declare bound_object_segment bit (1); declare 1 found, 2 profile bit (1), 2 symbol_table bit (1), 2 data bit (1); declare hardcore_bound_segpath char (168); declare hardcore_object_ptr ptr; declare hardlp ptr; declare hp ptr; declare last_program_ptr ptr; declare linkage_copy_ptr ptr; declare lp ptr; declare p ptr; /* A temp segment is needed to store a copy of the internal static profile data for hardcore segments, since ring 0 data cannot be read directly from ring 4 */ if args.hardcore then call get_seg (1, linkage_copy_ptr); /* Get temp segs for temp profile data storage */ if constructing then do; call get_seg (2, program_ptr); call get_seg (3, value_ptr); pfd_file_control.last_component = -1; call extend_temp_data_file; pfd_ptr = pfd_file_control.component (0); /* Set up temp profile data header */ pfd_header.version = pfd_format_version_1; pfd_header.mbz = "0"b; pfd_header.date_time_stored = clock (); pfd_header.person_project = get_group_id_ (); pfd_header.first_program = null_msf_ptr; if args.comment then pfd_header.comment = comment; else pfd_header.comment = ""; last_temp_data_word.component = 0; last_temp_data_word.offset = size (pfd_header) - 1; last_program_ptr = null; /* No previous program data */ end; /* Other initialization */ hardlp = null; /* Hardcore linkage section not copied yet */ sb = stackbaseptr (); /* Scan all specified program names. */ do prog_nr = 1 to n_program_names; call cu_$arg_ptr (program_name_array (prog_nr), arg_ptr, arg_len, code); call err_check; /* No error expected */ /* Initialize scan of this program data */ string (found) = ""b; /* Get pointer to the program's symbol table. For hardcore programs, find name of bound segment containing the program and use this name to search for the ring 4 library copy of the bound segment (using the specified search dirs). */ if args.hardcore then begin; declare hardcore_bound_segname char (32); call ring0_get_$segptr ("", arg, hardcore_object_ptr, code); /* Get ptr to ring 0 object seg */ if code = 0 then call ring0_get_$name ("", hardcore_bound_segname, ptr (hardcore_object_ptr, 0), code); /* Get primary program name */ if code = 0 then begin; declare search_nr fixed binary; code = error_table_$noentry; do search_nr = 1 to n_search_paths while (code ^= 0); hardcore_bound_segpath = rtrim (search_path (search_nr)) || ">" || hardcore_bound_segname; /* Pathname of ring 4 library copy */ call find_object (hardcore_bound_segpath, p, hp, bound_object_segment, code); /* Try to initiate the copy */ end; end; end; else call find_object (arg, p, hp, bound_object_segment, code); if code ^= 0 then if code = error_table_$name_not_found then call error (0, "Reference name not found. Program has not been executed. " || arg); else call error (code, arg); /* Probably entry not found */ /* Find linkage section */ if args.hardcore then begin; declare hardcore_object_segnr fixed binary; declare 1 lot_item aligned, 2 linkage_ptr ptr unaligned; declare lot_ptr ptr; hardcore_object_segnr = bin (baseno (hardcore_object_ptr)); call ring0_get_$segptr ("", "lot", lot_ptr, code); /* Get ptr to ring 0 table of linkage sections */ call err_check; /* No error expected */ call ring_zero_peek_ (addrel (lot_ptr, hardcore_object_segnr), addr (lot_item), 1, code); call err_check; /* No error expected */ if unspec (lot_item) = "0"b then call error (error_table_$noentry, arg); /* Program's active linkage nonexistent */ lp = lot_item.linkage_ptr; /* Unal to aligned */ end; else begin; /* Non-hardcore */ declare object_segnr fixed binary; object_segnr = bin (baseno (p)); isotp = stack_header.isot_ptr; if unspec (isot.isp (object_segnr)) = "0"b | (isotp -> isot1(object_segnr).fault = "11"b) then call error (0, "Program has not been executed. " || arg); lp = isot.isp (object_segnr); /* Ptr to active linkage */ end; /* Scan data of each component of bound object segment */ another_component = "1"b; do while (another_component); call scan_component; another_component = p -> std_symbol_header.next_block ^= ""b; if another_component then p = addrel (hp, p -> std_symbol_header.next_block); end; /* Check for no profile data */ if ^found.profile then call error (0, "Program was not compiled with -profile. " || arg); if ^found.symbol_table then call error (0, "Program's symbol table has been removed. " || arg); if ^found.data & constructing then call error (0, "Program has not been executed since its profile data was reset. " || arg); end; return; /* Scan data of an unbound object segment or one component of a bound object segment. */ scan_component: procedure; declare 1 last_temp_data aligned like msf_ptr_template; declare long bit (1); declare map ptr; declare overhead fixed binary; declare pf ptr; declare pf_loc bit (18); declare pfh ptr; declare q ptr; declare sp ptr; declare total_cost_or_time fixed binary (35); declare total_count fixed binary (35); declare total_page_faults fixed binary (35); if p -> std_symbol_header.identifier ^= "symbtree" then if p -> symbol_header.translator.code = "010100000"b then call error (0, arg || " is not a standard object segment."); else return; if p -> std_symbol_header.area_pointer = "0"b then return; q = addrel (p, p -> std_symbol_header.area_pointer); if q -> pl1_symbol_block.identifier ^= "pl1info" then return; long = q -> pl1_symbol_block.flags.long_profile; if ^q -> pl1_symbol_block.flags.profile & ^long then return; pf_loc = q -> pl1_symbol_block.profile; /* At this point it is known that the program component has profile data (zero or not) */ found.profile = "1"b; if q -> pl1_symbol_block.table_removed then return; found.symbol_table = "1"b; /* Set up temp (partial) program data header */ if constructing then begin; declare source_map_ptr ptr; declare string_len fixed binary (21); declare string_ptr ptr; declare based_string char (string_len) based (string_ptr); program.next_program = null_msf_ptr; string_ptr = addrel (p, q -> pl1_symbol_block.segname.offset); string_len = bin (q -> pl1_symbol_block.segname.size); program.name = based_string; if args.output_file & ^bound_object_segment & get_program_name (prog_nr) ^= program.name then call com_err_ (0, me, "Name of ^a in profile data file is ^a.", arg, program.name); program.translator = p -> std_symbol_header.generator; program.flags.long_profile = long; program.flags.mbz = "0"b; program.source_path_array = null_msf_ptr; program.n_operators = 0; program.operator_array = null_msf_ptr; program.n_values = 0; program.value_array = null_msf_ptr; source_map_ptr = addrel (p, p -> std_symbol_header.source_map); program.last_source_path = source_map_ptr -> source_map.number - 1; source_path_ptr = addrel (program_ptr, size (program)); operator_ptr = addrel (source_path_ptr, size (source_path_array)); do i = 0 to hbound (source_path_array, 1); string_ptr = addrel (p, source_map_ptr -> source_map.map (i + 1).pathname.offset); string_len = bin (source_map_ptr -> source_map.map (i + 1).pathname.size); source_path_array (i) = based_string; end; total_count = 0; total_cost_or_time = 0; total_page_faults = 0; end; /* Initialize statement map base */ sp = addrel (p, q -> pl1_symbol_block.map.first); if args.hardcore then do; /* copy entire linkage if hardcore */ if hardlp ^= lp then begin; /* suppress copy if same seg */ declare bword bit (36) aligned based; declare 1 copy_lh aligned like header; /* Copy of hardcore linkage header */ declare same bit (1); declare word bit (36) aligned; declare reloff fixed binary (18); reloff = bin (p -> std_symbol_header.mini_truncate) - 1; call ring_zero_peek_ (addrel (hardcore_object_ptr, reloff), addr (word), 1, code); /* check right seg */ if code = 0 then same = ptr (hp, reloff) -> bword = word; else same = "0"b; if ^same then do; call com_err_ (0, me, "Hardcore program ^a does not match library copy ^a|^o", arg, hardcore_bound_segpath, reloff); goto quit; end; call ring_zero_peek_ (lp, addr (copy_lh), size (copy_lh), code); if code ^= 0 then call error (code, arg); call ring_zero_peek_ (lp, linkage_copy_ptr, bin (copy_lh.block_length), code); if code ^= 0 then call error (code, arg); hardlp = lp; end; pf = addrel (linkage_copy_ptr, pf_loc); /* generate profile ptr */ end; else pf = addrel (lp, pf_loc); /* non-hardcore */ /* Scan through a single program's profile. */ if long then do; pfh = pf; /* Pointer to long_profile header */ if pfh -> long_profile_header.control.count ^= 0 then begin; declare entry_index fixed binary; overhead = float (pfh -> long_profile_header.control.vcpu) / float (pfh -> long_profile_header.control.count); pf = addrel (pfh, size (long_profile_header)); /* Skip past header to find first data */ do entry_index = 1 to pfh -> long_profile_header.nentries; map = addrel (sp, pf -> long_profile_entry.map); call scan_statement_data; pf = addrel (pf, size (long_profile_entry)); end; end; end; else do map = addrel (sp, pf -> profile_entry.map) repeat addrel (sp, pf -> profile_entry.map) while (map -> statement_map.line ^= (14)"1"b); call scan_statement_data; pf = addrel (pf, size (profile_entry)); end; /* Reset long_profile current data header */ if ^constructing then do; if long then begin; declare n fixed binary; n = pfh -> long_profile_header.nentries; unspec (pfh -> long_profile_header) = "0"b; pfh -> long_profile_header.nentries = n; pfh -> long_profile_header.last_offset = dummy_entry_offset; end; return; end; /* Finish storing data for this program component */ program.total_count = total_count; program.total_cost_or_time = total_cost_or_time; program.total_page_faults = total_page_faults; /* Sort values into ascending line order */ /* Algorithm is Shell sort */ n_values = program.n_values; /* For efficiency */ interval = n_values; do while (interval > 1); interval = 2 * divide (interval, 4, 18) + 1; do i = 1 to n_values - interval; k = i + interval; comparing = "1"b; do while (comparing); comparing = "0"b; j = k - interval; if unspec (value_array (j).source) > unspec (value_array (k).source) then begin; declare 1 temp_value aligned like value_array; temp_value = value_array (k); value_array (k) = value_array (j); value_array (j) = temp_value; if j > interval then do; comparing = "1"b; k = j; end; end; end; end; end; /* Copy and thread partial program data (now complete) to latest temp profile data file. */ call store_temp_data (program_ptr, size (program)); if last_program_ptr = null then pfd_header.first_program = last_temp_data; else last_program_ptr -> program.next_program = last_temp_data; last_program_ptr = ptr_from_msf_ptr (last_temp_data); call store_temp_data (source_path_ptr, size (source_path_array)); last_program_ptr -> program.source_path_array = last_temp_data; if program.n_operators ^= 0 then do; call store_temp_data (operator_ptr, size (operator_array)); last_program_ptr -> program.operator_array = last_temp_data; end; if program.n_values ^= 0 then do; call store_temp_data (value_ptr, size (value_array)); last_program_ptr -> program.value_array = last_temp_data; end; return; /* Scan the profile data for one statement. */ scan_statement_data: procedure; declare cost_or_time fixed binary (35); declare count fixed binary (35); declare instruction fixed binary (35); declare instruction_array_ptr ptr; declare map2 ptr; declare masked_instruction bit (36); declare n_instructions fixed binary; declare instruction_array (n_instructions) bit (36) aligned based (instruction_array_ptr); /* Reset current profile data */ if ^constructing then do; if long then do; pf -> long_profile_entry.count = 0; pf -> long_profile_entry.vcpu = 0; pf -> long_profile_entry.pf = 0; end; else pf -> profile_entry.count = 0; return; end; map2 = addrel (map, size (statement_map)); /* Pointer to next statement map entry */ n_instructions = bin (map2 -> statement_map.location) - bin (map -> statement_map.location); instruction_array_ptr = ptr (p, map -> statement_map.location); /* Create next temp (partial) value element */ program.n_values = program.n_values + 1; value = program.n_values; value_array (value).source.file = bin (map -> statement_map.file); value_array (value).source.line = bin (map -> statement_map.line); value_array (value).source.statement = bin (map -> statement_map.statement); value_array (value).source.pf_entry_seq = 0; if value > 1 then if value_array (value).source.file = value_array (value - 1).source.file & value_array (value).source.line = value_array (value - 1).source.line & value_array (value).source.statement = value_array (value - 1).source.statement then value_array (value).source.pf_entry_seq = value_array (value - 1).source.pf_entry_seq + 1; value_array (value).n_operators = 0; value_array (value).first_operator = program.n_operators + 1; if long then count = pf -> long_profile_entry.count; else count = pf -> profile_entry.count; if count ^= 0 then found.data = "1"b; /* Store all instructions in this statement that call operators */ if long then i = 2; /* Skip long_profile operator */ else i = 1; do instruction = i to n_instructions; masked_instruction = instruction_array (instruction) & "700000777777"b3; if masked_instruction = "000000700100"b3 /* tsx0 pr0|0 */ | masked_instruction = "000000710100"b3 /* tra pr0|0 */ | masked_instruction = "000000273100"b3 /* tsp3 pr0|0 */ | masked_instruction = "200000272100"b3 /* tsp2 pr2|0 (entry operators) */ | masked_instruction = "000000707100"b3 /* tsx7 pr0|0 (BASIC operators) */ then do; /* Found an instruction that calls an operator */ program.n_operators = program.n_operators + 1; /* Per program */ value_array (value).n_operators = value_array (value).n_operators + 1; /* Per statement */ operator_array (program.n_operators) = instruction_array (instruction); /* Store instruction as next operator_array element */ end; end; /* Calculate statement cost */ if long then do; if count = 0 then cost_or_time = 0; else cost_or_time = pf -> long_profile_entry.vcpu - overhead * count; /* Virtual CPU time minus long_profile overhead */ if cost_or_time < 0 then cost_or_time = 0; /* Null statements should have zero time */ end; else do; cost_or_time = n_instructions - 1; /* Subtract cost of the aos instruction */ cost_or_time = cost_or_time + 9 * value_array (value).n_operators; /* Each operator call counts as 10 */ /* Subtract cost of epplp instruction at start of profile aos sequence if it would have been generated without profile. This check is not made correctly for some EIS instructions. */ if instruction_array (1) = "600044370120"b3 /* epplp sp|44,* */ then begin; declare epplp bit (1) aligned; declare use_lp bit (1) aligned; epplp = "0"b; use_lp = "0"b; do instruction = 3 to n_instructions while (^epplp & ^use_lp); use_lp = (instruction_array (instruction) & "700000000100"b3) = "400000000100"b3; if ^use_lp then epplp = substr (instruction_array (instruction), 19, 10) = "370"b3 || "0"b; end; if epplp | ^use_lp then cost_or_time = cost_or_time - 1; end; cost_or_time = cost_or_time * count; /* Statement cost times executions */ end; /* Store statement data */ value_array (value).count = count; value_array (value).cost_or_time = cost_or_time; if long then value_array (value).page_faults = pf -> long_profile_entry.pf; else value_array (value).page_faults = 0; /* Sum up totals */ total_count = total_count + count; total_cost_or_time = total_cost_or_time + cost_or_time; if long then total_page_faults = total_page_faults + pf -> long_profile_entry.pf; end scan_statement_data; /* Copy partial (now complete) data structure into latest temp data segment */ /* On return, last_temp_data msf-points to the copied data, last_temp_data_word msf-points to the last word of the copied data. */ store_temp_data: procedure (from_ptr, n_words); declare from_ptr ptr; /* (Input) */ declare n_words fixed binary (19); /* (Input) */ declare word_array (n_words) bit (36) aligned based; if last_temp_data_word.offset + n_words >= sys_info$max_seg_size then do; call extend_temp_data_file; last_temp_data.component = pfd_file_control.last_component; last_temp_data.offset = 0; end; else do; last_temp_data.component = last_temp_data_word.component; last_temp_data.offset = last_temp_data_word.offset + 1; end; ptr_from_msf_ptr (last_temp_data) -> word_array = from_ptr -> word_array; last_temp_data_word.component = last_temp_data.component; last_temp_data_word.offset = last_temp_data.offset + n_words - 1; end store_temp_data; end scan_component; /* Find (and initiate) the specified program */ find_object: procedure (name, p, hp, bound_object_segment, code); declare name char (*); /* (Input) */ declare p ptr; /* (Output) Component symbol block pointer */ declare hp ptr; /* (Output) Base of symbol section pointer */ declare bound_object_segment bit (1); /* (Output) */ declare code fixed binary (35); /* (Output) */ declare delim char (1); bound_object_segment = "1"b; if search (name, "<>") = 0 then delim = "$"; /* Reference name */ else delim = "|"; /* Pathname */ hp = cv_ptr_ (rtrim (name) || delim || "bind_map", code); /* Bound segment */ if code = 0 then p = addrel (hp, hp -> std_symbol_header.next_block); else do; /* Non-bound segment */ hp = cv_ptr_ (rtrim (name) || delim || "symbol_table", code); p = hp; bound_object_segment = "0"b; end; end find_object; /* Extend temp profile data by one segment */ extend_temp_data_file: procedure; if pfd_file_control.last_component >= hbound (pfd_file_control.component, 1) then call error (error_table_$file_is_full, "Temporary (internal) data."); /* Should never happen */ pfd_file_control.last_component = pfd_file_control.last_component + 1; call get_temp_segment_ (me, pfd_file_control.component (pfd_file_control.last_component), code); call err_check; end extend_temp_data_file; end scan_data; /* Copy entire temp profile data to permanent pfd file. */ store_output_file: procedure; declare component fixed binary; call expand_pathname_$add_suffix (output_file, profile_data_suffix, dirname, entryname, code); if code ^= 0 then call error (code, output_file); call msf_manager_$open (dirname, entryname, output_fcb, code); if output_fcb = null then call file_error; do component = 0 to pfd_file_control.last_component - 1; call store_output_data (sys_info$max_seg_size); end; call store_output_data (last_temp_data_word.offset + 1); call msf_manager_$adjust (output_fcb, component, 36 * (last_temp_data_word.offset + 1), "111"b, code); if code ^= 0 then call file_error; call msf_manager_$close (output_fcb); output_fcb = null; return; store_output_data: procedure (n_words); declare n_words fixed binary (19); /* (Input) */ declare output_ptr ptr; declare word_array (n_words) bit (36) aligned based; call msf_manager_$get_ptr (output_fcb, component, "1"b /* Create */, output_ptr, (0), code); if output_ptr = null then call file_error; output_ptr -> word_array = pfd_file_control.component (component) -> word_array; end store_output_data; end store_output_file; /* Subroutine to print or list profile data (-print or -list control args) */ print_or_list: procedure (listing); declare listing bit (1); /* -list rather than -print */ declare date_time char (24); declare print_program bit (1); declare more_than_one_program bit (1); declare this_value fixed binary (18); declare threshold (4) fixed binary (35); more_than_one_program = "0"b; /* Assume one program (for newpages) */ /* Output data header */ if args.input_file & ^args.no_header & ^listing then call output_header (iox_$user_output); /* Output data for all programs */ do program_ptr = ptr_from_msf_ptr (pfd_header.first_program) repeat ptr_from_msf_ptr (program.next_program) while (program_ptr ^= null); /* Select subset of programs (-input_file only) */ if args.input_file & n_program_names > 0 then do; do prog_nr = 1 to n_program_names while (get_program_name (prog_nr) ^= program.name); end; print_program = prog_nr <= n_program_names; end; else print_program = "1"b; if print_program then if listing then call list_one_program; else call print_one_program; end; return; /* Print the profile data for one program. */ print_one_program: procedure; declare skip bit (1); declare sort_array_ptr ptr; declare sort_array (n_values) fixed binary (18) aligned based (sort_array_ptr); call ioa_ ("^/Program: ^a", program.name); if ^args.no_header then call ioa_ (" LINE STMT COUNT ^[TIME^;COST^] STARS^[ AVGTIME PGEFLTS^] OPERATORS", program.long_profile, program.long_profile); operator_ptr = ptr_from_msf_ptr (program.operator_array); value_ptr = ptr_from_msf_ptr (program.value_array); n_values = program.n_values; /* Sort via sorting array */ if args.sort then begin; declare disordered bit (1); declare sort_test fixed binary; declare cost_or_time_test fixed binary internal static options (constant) initial (3); declare count_test fixed binary internal static options (constant) initial (1); declare page_faults_test fixed binary internal static options (constant) initial (2); call get_seg (2, sort_array_ptr); do value = 1 to n_values; /* Initialize to identity vector */ sort_array (value) = value; end; /* Select field on which to sort */ if sort_field (1) then sort_test = count_test; else if (sort_field (4) | sort_field (5)) & program.long_profile then sort_test = page_faults_test; else sort_test = cost_or_time_test; /* Default */ /* Shell sort algorithm */ interval = n_values; do while (interval > 1); interval = 2 * divide (interval, 4, 18) + 1; do i = 1 to n_values - interval; k = i + interval; comparing = "1"b; do while (comparing); comparing = "0"b; j = k - interval; goto case (sort_test); case (1): /* count_test */ disordered = value_array (sort_array (j)).count < value_array (sort_array (k)).count; goto end_case; case (2): /* page_faults_test */ disordered = value_array (sort_array (j)).page_faults < value_array (sort_array (k)).page_faults; goto end_case; case (3): /* cost_or_time_test */ disordered = value_array (sort_array (j)).cost_or_time < value_array (sort_array (k)).cost_or_time; goto end_case; end_case: if disordered then do; value = sort_array (k); sort_array (k) = sort_array (j); sort_array (j) = value; if j > interval then do; comparing = "1"b; k = j; end; end; end; end; end; end; call init_star_thresholds (program.total_cost_or_time); exit = "0"b; do value = 1 to n_values while (^exit); skip = "0"b; /* Test for terminating conditions */ if args.sort then this_value = sort_array (value); else this_value = value; if args.first then if value > first then exit = "1"b; if (args.to | args.from) & value_array (value).file ^= 0 then exit = "1"b; if args.to then if value_array (value).line > to then exit = "1"b; if args.from then if value_array (value).line < from then skip = "1"b; if args.brief & value_array (this_value).count = 0 then skip = "1"b; if ^exit & ^skip then begin; declare average_time fixed binary (35); declare operator_name char (32) aligned; /* Output this value */ if program.long_profile & value_array (this_value).count ^= 0 then average_time = float (value_array (this_value).cost_or_time) / float (value_array (this_value).count) + 0.5; else average_time = 0; line_buffer = ""; do i = value_array (this_value).first_operator to value_array (this_value).first_operator + value_array (this_value).n_operators - 1; call find_operator_name_ (program.translator, addr (operator_array (i)), operator_name); if operator_name ^= "" & line_buffer ^= "" then line_buffer = line_buffer || ", "; line_buffer = line_buffer || rtrim (operator_name); end; call ioa_ ( "^[^s^6d ^;^d-^d^8t^]^[^4d^;^s^4x^] ^7d ^9d ^4a ^[^[^7d^;^s^7x^] ^[^8d^;^s^8x^] ^;^4s^]^a", value_array (this_value).file = 0, value_array (this_value).file, value_array (this_value).line, value_array (this_value).statement ^= 1, value_array (this_value).statement, value_array (this_value).count, value_array (this_value).cost_or_time, stars (), program.long_profile, average_time ^= 0, average_time, value_array (this_value).page_faults ^= 0, value_array (this_value).page_faults, line_buffer); end; end; /* Output totals for this program */ call ioa_ ("-------"); /* Separator for clarity */ call ioa_ ("Totals: ^11d ^9d^[ ^24d^]", program.total_count, program.total_cost_or_time, program.long_profile, program.total_page_faults); end print_one_program; /* List the profile data for one program. */ list_one_program: procedure; declare source_length fixed binary (21); /* Open the source segment. */ call open_file (0); /* Open the listing file */ if list_iocb = null then begin; declare list_file char (32); if n_program_names = 0 then list_file = rtrim (program.name) || "." || profile_listing_suffix; else list_file = rtrim (get_program_name (1)) || "." || profile_listing_suffix; call iox_$attach_name (me || "." || unique_chars_ (""b), list_iocb, "vfile_ " || list_file, codeptr (list_one_program), code); if code = 0 then call iox_$open (list_iocb, Stream_output, "0"b, code); if code ^= 0 then call error (code, list_file); end; /* Output program data header */ if more_than_one_program then call ioa_$ioa_switch (list_iocb, "^|"); else more_than_one_program = "1"b; call ioa_$ioa_switch_nnl (list_iocb, "Profile listing of ^a>^a", dirname, entryname); if args.input_file then do; call expand_pathname_$add_suffix (input_file, profile_data_suffix, dirname, entryname, code); call err_check; call output_header (list_iocb); end; else call ioa_$ioa_switch (list_iocb, ""); call date_time_ (clock (), date_time); call ioa_$ioa_switch (list_iocb, "Date: ^a", date_time); call ioa_$ioa_switch (list_iocb, "Total count: ^d Total ^[time: ^d Total page faults: ^d^;cost: ^d^s^]", program.total_count, program.long_profile, program.total_cost_or_time, program.total_page_faults); /* Output profile data for all source segments that contain code. */ call init_star_thresholds (program.total_cost_or_time); value_ptr = ptr_from_msf_ptr (program.value_array); n_values = program.n_values; this_value = 1; call list_file (0); do while (this_value <= n_values); call open_file (value_array (this_value).file); call ioa_$ioa_switch (list_iocb, "^/Include file ^d: ^a>^a", value_array (this_value).file, dirname, entryname) ; call list_file (value_array (this_value).file); end; return; /* Open one source segment. */ open_file: procedure (file); declare file fixed binary (10) unsigned unaligned; /* (Input) */ declare source_bc fixed binary (24); source_path_ptr = ptr_from_msf_ptr (program.source_path_array); call expand_pathname_ (source_path_array (file), dirname, entryname, code); if code ^= 0 then call error (code, source_path_array (file)); /* Specified source_dir overrides original directory */ if args.source_dir then dirname = source_dir; call hcs_$initiate_count (dirname, entryname, "", source_bc, 0, source_ptr, code); if source_ptr = null & (file = 0 | ^args.source_dir) then call file_error; /* Look for include files in their original directory if they weren't in the source_dir. */ if source_ptr = null then do; call expand_pathname_ (source_path_array (file), dirname, entryname, code); call err_check; call hcs_$initiate_count (dirname, entryname, "", source_bc, 0, source_ptr, code); if source_ptr = null then do; dirname = source_dir; call file_error; end; end; source_length = divide (source_bc + 8, 9, 21); if source_length = 0 then do; code = error_table_$zero_length_seg; call file_error; end; end open_file; /* Create a profile listing for one source segment. */ list_file: procedure (file); declare file fixed binary (10) unsigned unaligned; /* (Input) */ declare column fixed binary; declare continuation_line bit (1); declare line fixed binary (21); declare scan_length fixed binary (21); declare source_position fixed binary (21); declare tab_column fixed binary; declare source char (source_length) based (source_ptr); /* Print the listing header. */ call ioa_$ioa_switch (list_iocb, "^/ COUNT ^[TIME STARS P ^;COST STARS^] LINE SOURCE", program.long_profile); /* Output all requested values for this program data */ call initialize_line; line = 1; source_position = 1; do while (source_position <= length (source)); scan_length = search (substr (source, source_position), HT_NL) - 1; if scan_length < 0 then scan_length = length (substr (source, source_position)); begin; declare chars char (scan_length) defined (source) position (source_position); call put_chars (chars); end; if source_position + scan_length <= length (source) then if substr (source, source_position + scan_length, 1) = HT then begin; declare SP10 char (10) internal static options (constant) initial (""); declare spaces_to_tab_stop char (10 - mod (tab_column - 1, 10)) defined (SP10); call put_chars (spaces_to_tab_stop); end; else call put_nl; /* NL */ source_position = source_position + scan_length + 1; end; /* Finish last line if the source segment doesn't end with a NL. */ if index (reverse (source), NL) ^= 1 then call put_nl; /* Output multiple profile data for the last line. */ call put_profile_data ("0"b); /* All finished with this source segment. */ call hcs_$terminate_noname (source_ptr, code); source_ptr = null; call err_check; return; /* Store characters into the listing file. */ put_chars: procedure (chars); declare chars char (*); /* (Input) */ declare chars_to_store fixed binary (21); declare start_position fixed binary (21); start_position = 1; do while (start_position <= length (chars)); call put_profile_data ("1"b); chars_to_store = min (length (substr (chars, start_position)), line_length - column + 1); line_buffer = line_buffer || substr (chars, start_position, chars_to_store); start_position = start_position + chars_to_store; column = column + chars_to_store; tab_column = tab_column + chars_to_store; if column > line_length then call put_line; end; end put_chars; /* Store a NL in the listing file. */ put_nl: procedure; call put_profile_data ("1"b); call put_line; call initialize_line; line = line + 1; end put_nl; /* Prefix a line in the listing file with profile data if necessary. */ put_profile_data: procedure (more_source_characters); declare more_source_characters bit (1) aligned; /* (Input) */ declare previous_line_profile_data bit (1) aligned; declare this_line_profile_data bit (1) aligned; do while (column = 1); previous_line_profile_data = "0"b; this_line_profile_data = "0"b; if this_value <= n_values then if value_array (this_value).line < line & value_array (this_value).file = file then previous_line_profile_data = "1"b; else if value_array (this_value).line = line & value_array (this_value).file = file then this_line_profile_data = "1"b; if previous_line_profile_data | this_line_profile_data then do; call ioa_$ioa_switch_nnl (list_iocb, "^[^7d^;^7x^s^] ^[^8d^;^8x^s^] ^4a ^[^[^2d^;^2x^s^] ^;^2s^]^[^5d^;^5x^s^]^[^/^; ^]", value_array (this_value).count ^= 0, value_array (this_value).count, value_array (this_value).cost_or_time ^= 0, value_array (this_value).cost_or_time, stars (), program.long_profile, value_array (this_value).page_faults ^= 0, value_array (this_value).page_faults, ^continuation_line & this_line_profile_data, line, previous_line_profile_data); this_value = this_value + 1; end; else if more_source_characters then call ioa_$ioa_switch_nnl (list_iocb, "^22x^[^3x^]^[^5d^;^5x^s^] ", program.long_profile, ^continuation_line, line); if ^previous_line_profile_data then do; continuation_line = "1"b; if program.long_profile then column = 32; else column = 29; end; end; end put_profile_data; /* Initialize line buffer */ initialize_line: procedure; column = 1; tab_column = 1; line_buffer = ""; continuation_line = "0"b; end initialize_line; /* Store source portion of line into listing file */ put_line: procedure; line_buffer = line_buffer || NL; call iox_$put_chars (list_iocb, addrel (addr (line_buffer), 1), length (line_buffer), code); call err_check; line_buffer = ""; column = 1; end put_line; end list_file; end list_one_program; /* Output header describing profile data file */ output_header: procedure (iocb); declare iocb ptr; /* (Input) */ call ioa_$ioa_switch (iocb, "^/Profile data file ^a>^a", dirname, entryname); call date_time_ (pfd_header.date_time_stored, date_time); call ioa_$ioa_switch (iocb, "Created by ^a on ^a", pfd_header.person_project, date_time); if pfd_header.comment ^= "" then call ioa_$ioa_switch (iocb, "Comment: ^a", pfd_header.comment); end output_header; /* Initialize thresholds to print given numbers of stars. Algorithm: if this_value_cost_or_time = 0 | total_cost_or_time = 0 then number_stars = 0 else number_stars = min (floor (log_base_2 (5 * this_value_cost_or_time / total_cost_or_time) + 4), 4) */ init_star_thresholds: procedure (total_cost_or_time); declare total_cost_or_time fixed binary (35); /* (Input) */ threshold (1) = divide (total_cost_or_time, 40, 35) + 1; threshold (2) = divide (total_cost_or_time, 20, 35) + 1; threshold (3) = divide (total_cost_or_time, 10, 35) + 1; threshold (4) = divide (total_cost_or_time, 5, 35) + 1; end init_star_thresholds; /* Prepare stars field */ stars: procedure returns (char (4)); declare n fixed binary (35); n = value_array (this_value).cost_or_time; if value_array (this_value).count = 0 then return ("."); else if n < threshold (1) then return (""); else if n < threshold (2) then return ("*"); else if n < threshold (3) then return ("**"); else if n < threshold (4) then return ("***"); else return ("****"); end stars; end print_or_list; /* Subroutine to plot profile data on graphics terminal */ plot: procedure; declare plot_program bit (1); /* Plot data for all specified programs */ do program_ptr = ptr_from_msf_ptr (pfd_header.first_program) repeat ptr_from_msf_ptr (program.next_program) while (program_ptr ^= null); /* Select subset of programs (-input_file only) */ if args.input_file & n_program_names > 0 then do; do prog_nr = 1 to n_program_names while (get_program_name (prog_nr) ^= program.name); end; plot_program = prog_nr <= n_program_names; end; else plot_program = "1"b; if plot_program then call plot_one_program; end; return; /* Plot profile data for one program. */ plot_one_program: procedure; declare plot_array_ptr ptr; declare skip bit (1); declare x_array_ptr ptr; declare y_array_ptr ptr; declare 1 plot_array (divide (sys_info$max_seg_size, 2, 19)) aligned based (plot_array_ptr), 2 line float binary, 2 data float binary; declare x_array (2 * n_values + 2) float binary based (x_array_ptr); declare y_array (2 * n_values + 2) float binary based (y_array_ptr); call get_seg (1, plot_array_ptr); call get_seg (2, x_array_ptr); call get_seg (3, y_array_ptr); value_ptr = ptr_from_msf_ptr (program.value_array); /* Copy data into plot_array so it can be manipulated easily */ n_values = 0; exit = "0"b; do value = 1 to program.n_values while (^exit); skip = "0"b; /* Select data values within range */ if value_array (value).file ^= 0 then exit = "1"b; if args.to then if value_array (value).line > to then exit = "1"b; if args.from then if value_array (value).line < from then skip = "1"b; if ^exit & ^skip then do; /* Create zero values between active line numbers */ if n_values ^= 0 /* Start at 2nd value */ then do while (value_array (value).line > plot_array (n_values).line + 1); n_values = n_values + 1; /* Create new point */ plot_array (n_values).line = plot_array (n_values - 1).line + 1.0; plot_array (n_values).data = 0.0; end; /* Store next selected active point */ n_values = n_values + 1; /* Copy one selected data value */ plot_array (n_values).line = float (value_array (value).line); if plot_field (1) then plot_array (n_values).data = float (value_array (value).count); else if (plot_field (4) | plot_field (5)) & program.long_profile then plot_array (n_values).data = float (value_array (value).page_faults); else plot_array (n_values).data = float (value_array (value).cost_or_time); end; end; if n_values = 0 then do; n_values = 1; plot_array (1).line = 0.0; plot_array (1).data = 0.0; end; /* Merge points together if too many to plot in reasonable time */ /* The algorithm used is distributed multiplication: an appropriate constant c is found by division and it is integrated (added), with the overflow (=1) indicating when to merge adjacent points. Thus, for example, if c=.5 (the case where n_values=2*max_points) then merging will happen for every other point. */ if n_values > max_points then begin; declare c float binary; declare c1 float binary; c = 1.0 - (max_points - 1) / n_values; /* Complement of when NOT to merge */ c1 = c; /* Initial value */ i = 1; /* Target for merging */ do value = 2 to n_values; c1 = c1 + c; /* Integrate */ if c1 >= 1.0 /* Overflow */ then do; c1 = c1 - 1.0; /* Truncate the overflow */ plot_array (i).data = plot_array (i).data + plot_array (value).data; /* Merge by adding */ end; else do; i = i + 1; /* Copy point without merging */ plot_array (i) = plot_array (value); end; end; n_values = i; /* Merging changes number of points */ end; /* Add data for all statements on each line (to convert data from per-statement to per-line, and delete points having same data values (to speed plotting) */ i = 1; do value = 2 to n_values; if plot_array (value).line = plot_array (i).line then plot_array (i).data = plot_array (i).data + plot_array (value).data; /* Add data for same lines */ else if plot_array (i).data ^= plot_array (value).data | value = n_values /* Distinct or last point */ then do; i = i + 1; /* Copy each distinct point */ plot_array (i) = plot_array (value); end; end; n_values = i; /* Construct bar graph x_array and y_array */ /* Each value is turned into two points having same y value but x values of (line)+_0.5 to create the flat top of each bar. In addition, two endpoints are added at y=0 to create the sides of the outermost bars. */ y_array (1) = 0.0; /* Left endpoint */ do value = 1 to n_values; i = 2 * value - 1; /* Subscript of next xy point */ x_array (i), x_array (i + 1) = plot_array (value).line - 0.5; y_array (i + 1), y_array (i + 2) = plot_array (value).data; end; i = 2 * n_values + 1; /* Subscript of next-to-last xy point */ x_array (i), x_array (i + 1) = plot_array (n_values).line + 0.5; y_array (i + 1) = 0.0; /* Right endpoint */ /* Plot the points, connecting them with lines */ line_buffer = "Program: " || rtrim (program.name); if pfd_header.comment ^= "" then line_buffer = line_buffer || " (" || rtrim (pfd_header.comment) || ")"; call plot_$setup ((line_buffer), "LINE NUMBER" /* x legend */, table_1_upper_case (y_legend), Linear_linear, 0.0, Tick_marks, Normal_scaling); call plot_ (x_array, y_array, hbound (x_array, 1), Vectors_only, ""); end plot_one_program; end plot; /* Get a temp segment */ get_seg: procedure (number, target); declare number fixed binary; /* (Input) */ declare target ptr; /* (Output) */ if temp_seg_array (number) = null /* Else reuse previous temp segment */ then do; call get_temp_segment_ (me, temp_seg_array (number), code); call err_check; /* No error expected */ end; target = temp_seg_array (number); end get_seg; /* Get the program name from a command argument */ get_program_name: procedure (program_index) returns (char (32)); declare program_index fixed binary; /* (Input) */ declare entryname char (32); call cu_$arg_ptr (program_name_array (program_index), arg_ptr, arg_len, code); call err_check; call expand_pathname_ (arg, "", entryname, code); if code ^= 0 then call error (code, arg); return (entryname); end get_program_name; /* Convert msf pointer to pointer */ ptr_from_msf_ptr: procedure (msf_ptr) returns (ptr); declare 1 msf_ptr aligned like msf_ptr_template; if unspec (msf_ptr) = unspec (null_msf_ptr) then return (null); else return (ptr (pfd_file_control.component (msf_ptr.component), msf_ptr.offset)); end ptr_from_msf_ptr; end profile; */ ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved */