analyze_multics.pl1 11/05/86 1349.4r w 11/04/86 1042.5 135396 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ analyze_multics: azm: procedure () options (variable); /* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */ /* Main procedure for Multics Online Analysis subsystem 09/07/80 W. Olin Sibert Modified 06/23/83 by B. Braun to update user interface as per MTB-624 Modified 03 Nov 83 by B. Braun to fix reference thru null pointer when it encounters an unrecognized variable (phx16285). Modified 22 Oct 84 by B. Braun to add the ssu_ standard requests info dir, and the azm version number. Modified 27 Oct 84 by B. Braun to get rid of amu_arglist_ references as it was never used. Modified 13 Nov 84 by B. Braun to fix the RQO handler (phx17544). Modified 06 Dec 84 by B. Braun to call its start_up after initialization is complete. (phx18527). */ dcl abbrev_sw bit (1); dcl al fixed bin (21); dcl alp pointer; dcl amu_ptr ptr; dcl ap pointer; dcl arg char (al) based (ap); dcl argno fixed bin; dcl 1 azm_info_automatic aligned like azm_info automatic; dcl code fixed bin (35); dcl cond_uid bit(36) aligned; dcl debug_sw bit (1) aligned; dcl dirname char(168); dcl dn_lth fixed bin; dcl ename char(32); dcl i fixed bin; dcl info_dir char (168); dcl my_uid bit(36) aligned; dcl nargs fixed bin; dcl profile_len fixed bin(21); dcl profile_ptr ptr; dcl profile_str char(profile_len) based(profile_ptr); dcl prompt_len fixed bin(21); dcl prompt_ptr ptr; dcl prompt_string char(prompt_len) based (prompt_ptr); dcl quit_sw bit (1); dcl request_line char(request_line_len) based (request_line_ptr); dcl request_line_len fixed bin(21); dcl request_line_ptr ptr; dcl rq_sw bit (1) aligned; dcl startup_sw bit(1); dcl temp_ptr ptr; dcl where_ami_dir char (168); dcl where_ami_entry char (32); dcl where_ami_len fixed bin; dcl where_ami_ptr ptr; dcl why_sw bit (1); dcl sci_ptr pointer; dcl ssu_request_tables_$standard_requests bit(36) aligned external; dcl ssu_info_directories_$standard_requests char (168) external; /* External Static */ dcl azm_request_table_$azm_request_table_ fixed bin external static; dcl ( error_table_$bad_arg, error_table_$badopt, error_table_$noarg, ssu_et_$null_request_line, ssu_et_$program_interrupt, ssu_et_$request_line_aborted, ssu_et_$subsystem_aborted ) fixed bin (35) external static; dcl amu_$terminate_translation entry (ptr), com_err_ entry options (variable), continue_to_signal_ entry (fixed bin (35)), cu_$arg_count entry (fixed bin, fixed bin (35)), cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35)), expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)), find_condition_frame_ entry (ptr) returns(ptr), hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)), hcs_$get_uid_seg entry (ptr, bit(36) aligned, fixed bin(35)), hcs_$make_ptr entry (ptr, char(*), char(*), ptr, fixed bin(35)), initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)), ioa_ entry () options (variable), ioa_$nnl entry() options(variable), ssu_$add_info_dir entry (ptr, char(*), fixed bin, fixed bin(35)), ssu_$add_request_table entry (ptr, ptr, fixed bin, fixed bin(35)), ssu_$create_invocation entry (char (*), char (*), pointer, pointer, char (*), pointer, fixed bin (35)), ssu_$destroy_invocation entry (pointer), ssu_$execute_line entry (ptr, ptr, fixed bin (21), fixed bin (35)), ssu_$execute_start_up entry () options (variable), ssu_$get_area entry (ptr, ptr, char(*), ptr), ssu_$get_default_rp_options entry (ptr, char(8), ptr, fixed bin(35)), ssu_$listen entry (pointer, pointer, fixed bin (35)), ssu_$set_debug_mode entry (ptr, bit(1) aligned), ssu_$set_ec_suffix entry (ptr, char(32)), ssu_$set_info_ptr entry (pointer, pointer), ssu_$set_prompt entry (pointer, char (*) varying), ssu_$set_prompt_mode entry (ptr, bit(*)), ssu_$set_request_processor_options entry (ptr, ptr, fixed bin(35)); /* Internal Static */ dcl (False bit(1) init("0"b), True bit(1) init("1"b)) int static options(constant); dcl WHOAMI char (32) internal static options (constant) init ("analyze_multics"); dcl CURRENT_VERSION char(4) init ("2.3 ") int static options(constant); /* Condition Handlers */ dcl (cleanup, record_quota_overflow) condition; /* Builtins */ dcl (addr, codeptr, index, null, pointer, reverse, rtrim, substr, unspec) builtin; %page; where_ami_ptr, amu_ptr, sci_ptr, azm_info_ptr, amu_info_ptr, profile_ptr, request_line_ptr, prompt_ptr = null (); abbrev_sw, debug_sw, startup_sw, why_sw, quit_sw = "0"b; prompt_len = -1; profile_len, request_line_len, where_ami_len = 0; code = 0; /* KLUDGE, because new version of cu_$arg_count not here yet. */ on condition (cleanup) begin; call clean_up(); end; on condition (record_quota_overflow) begin; /* Did azm signal this? */ sp = find_condition_frame_ (null()); code = 0; /* get UID of owner of condition frame */ call hcs_$get_uid_seg(sp->stack_frame.entry_ptr, cond_uid, code); if code ^= 0 then do; call continue_to_signal_(code); return; end; /* get UID of me */ where_ami_ptr = codeptr (analyze_multics); call hcs_$get_uid_seg(where_ami_ptr, my_uid, code); if code ^= 0 then do; call continue_to_signal_(code); return; end; if cond_uid ^= my_uid then do; /* Not ours to handle */ /* But it is ours if signaled by amu_ */ /* get ptr to amu_ */ call hcs_$make_ptr (null(), "amu_", "", amu_ptr, code); if amu_ptr = null() then do; call continue_to_signal_(code); return; end; call hcs_$get_uid_seg(amu_ptr, my_uid, code); /* Get UID of amu_ */ if code ^= 0 then do; call continue_to_signal_(code); return; end; if cond_uid ^= my_uid then do; /* Not ours to handle */ call continue_to_signal_(code); return; end; end; /* We called it, We'll handle it */ call ioa_$nnl ("Record_quota_overflow:^2x"); if azm_info_ptr = null () then do; /* ok time to punt */ call ioa_ (); call continue_to_signal_ (code); end; amu_info_ptr = azm_info_automatic.aip; temp_ptr = null; if amu_info_ptr ^= null () then do; /* is current the first */ if amu_info.chain.prev = null () then do; /* is there a second */ if amu_info.chain.next ^= null () then do; /* ok try this one */ temp_ptr = amu_info_ptr; amu_info_ptr = amu_info.chain.next; end; else do; /* we are realy out of luck */ call continue_to_signal_ (code); end; end; else do; /* find the first */ temp_ptr = amu_info_ptr; do while (temp_ptr -> amu_info.chain.prev ^= null ()); temp_ptr = temp_ptr -> amu_info.chain.prev; end; amu_info_ptr = temp_ptr; temp_ptr = null; end; if amu_info.type = FDUMP_PROCESS_TYPE then call ioa_ ("Will try deleting ERF ^a and continue...",fdump_info.erf_name); else call ioa_ ("Deleting SAVE_PROC"); call amu_$terminate_translation (amu_info_ptr); if amu_info_ptr = null () then call continue_to_signal_ (code); end; end; /* end record_quota_overflow condition */ call cu_$arg_count (nargs, code); if code ^= 0 then do; call com_err_ (code, WHOAMI); return; end; do argno = 1 to nargs; call cu_$arg_ptr (argno, ap, al, (0)); if arg = "-request" | arg = "-rq" then do; call get_next_arg("request line", request_line_ptr, request_line_len); rq_sw = True; end; else if arg = "-profile" | arg = "-pf" then do; call get_next_arg ("profile path", profile_ptr, profile_len); call expand_pathname_$add_suffix(profile_str,"profile",dirname,ename,code); if code ^= 0 then call report_error(code, "^a",profile_str,""); call initiate_file_ (dirname, ename, R_ACCESS, profile_ptr, (0), code); if profile_ptr = null() then do; call com_err_(code, WHOAMI, " -profile ^a^[>^]^a ", dirname, ename^=">", ename); goto AZM_RETURN; end; abbrev_sw = True; end; else if arg = "-ab" | arg = "-abbrev" then do; abbrev_sw = True; end; else if arg = "-nab" | arg = "-no_abbrev" then do; abbrev_sw = False; end; else if arg = "-start_up" | arg = "-su" then do; startup_sw = True; end; else if arg = "-nsu" | arg = "-no_start_up" then do; startup_sw = False;; end; else if arg = "-prompt" then do; call get_next_arg ("prompt string", prompt_ptr, prompt_len); end; else if arg = "-no_prompt" then do; prompt_len = 0; end; else if arg = "-db" | arg = "-debug" then debug_sw = "1"b; else if arg = "-ndb" | arg = "-no_debug" then debug_sw = "0"b; else if (arg = "-quit") then quit_sw = "1"b; else do; if char(arg,1) = "-" then code = error_table_$badopt; else code = error_table_$bad_arg; call com_err_ (code, WHOAMI, "^a", arg); goto AZM_RETURN; end; end; /* of loop through arguments */ /* azm_invocation_list */ where_ami_ptr = pointer (codeptr (analyze_multics), 0); call hcs_$fs_get_path_name (where_ami_ptr, where_ami_dir, where_ami_len, where_ami_entry, code); if code ^= 0 then call report_error (code, WHOAMI, "where", ""); call ssu_$create_invocation ("azm", CURRENT_VERSION, (null ()), addr (azm_request_table_$azm_request_table_), ">documentation>subsystem>analyze_multics", sci_ptr, code); if code ^= 0 then call report_error(code,"^/While creating analyze_multics invocation.","", ""); call ssu_$add_info_dir (sci_ptr, ssu_info_directories_$standard_requests, 9999, code); if code ^= 0 then call report_error(code,"^/While adding standard ssu_ info directory.","", ""); call ssu_$add_request_table(sci_ptr, addr(ssu_request_tables_$standard_requests), 100000, code); if code ^= 0 then call report_error(code,"^/While adding standard ssu_ request table.","", ""); if (prompt_len = 0) then call ssu_$set_prompt_mode (sci_ptr, DONT_PROMPT); /* Do not prompt */ else if prompt_len >0 then do; /* set the user specified prompt */ call ssu_$set_prompt(sci_ptr, (prompt_string)); end; else do; /* set the default prompt */ call ssu_$set_prompt (sci_ptr, "^/azm^[ (^d)^]:^2x"); call ssu_$set_prompt_mode (sci_ptr, PROMPT | PROMPT_AFTER_NULL_LINES | DONT_PROMPT_IF_TYPEAHEAD); end; call ssu_$set_ec_suffix (sci_ptr, "azmec"); if abbrev_sw then do; call ssu_$get_default_rp_options(sci_ptr, RP_OPTIONS_VERSION_1, addr(local_rpo), (0)); local_rpo.abbrev_info.expand_request_lines = True; local_rpo.abbrev_info.default_profile_ptr = profile_ptr; local_rpo.abbrev_info.profile_ptr = profile_ptr; call ssu_$set_request_processor_options(sci_ptr, addr(local_rpo), (0)); end; azm_info_ptr = addr (azm_info_automatic); unspec (azm_info) = ""b; azm_info.version = AZM_INFO_VERSION_2; azm_info.aip = amu_info_ptr; call ssu_$get_area (sci_ptr, null (), "azm_area", azm_info.area_ptr); if amu_info_ptr ^= null () then do; if amu_info.type = FDUMP_TYPE | amu_info.type = FDUMP_PROCESS_TYPE then azm_info.flags.in_erf = "1"b; end; call ssu_$set_info_ptr (sci_ptr, azm_info_ptr); /* 6/24/83 currently debug mode does nothing, but it may in the future. -B. Braun */ if debug_sw then call ssu_$set_debug_mode(sci_ptr, debug_sw); if startup_sw then do; call ssu_$execute_start_up (sci_ptr, code); if code ^= 0 then call report_error(code,"^/While executing start_up.","", ""); end; if rq_sw then do; /* just one request line specified */ call ssu_$execute_line (sci_ptr, request_line_ptr, request_line_len, code); if code ^= 0 then do; if code = ssu_et_$request_line_aborted | code = ssu_et_$program_interrupt | code = ssu_et_$null_request_line then goto INVOKE_LISTEN; /* enter request loop */ if code = ssu_et_$subsystem_aborted then goto AZM_RETURN; call report_error(code,"^/While executing the request ^a.", (request_line), ""); end; end; if quit_sw then goto AZM_RETURN; INVOKE_LISTEN: call ssu_$listen(sci_ptr, null(),code); if code ^= ssu_et_$subsystem_aborted then call com_err_ (code,WHOAMI,"^/Calling subsystem listener."); AZM_RETURN: call clean_up (); return; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ clean_up: proc (); if azm_info_ptr ^= null() then do; amu_info_ptr = azm_info.aip; do while (amu_info_ptr ^= null); /* amu_$terminate_translation should reset the */ /* amu_info_chain and set amu_info_ptr to that value */ call amu_$terminate_translation (amu_info_ptr); end; end; if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr); return; end clean_up; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_next_arg: proc(Arg_expected, ap1, al1); /* This guy gets the next argument from the argument string, complaining if it's not there */ dcl Arg_expected char(*); dcl (ap1 ptr, al1 fixed bin(21)); if (argno + 1) > nargs then do; call report_error(error_table_$noarg, "A ^a expected after ^a.", Arg_expected, arg); return; end; argno = argno + 1; call cu_$arg_ptr (argno, ap1, al1, (0)); end get_next_arg; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ report_error: proc(ecode, message, str1, str2); /* reports error messages and aborts the line */ dcl ecode fixed bin(35), (message, str1, str2) char(*); call com_err_(ecode, WHOAMI, message, str1, str2); goto AZM_RETURN; end report_error; %page;%include access_mode_values; %page;%include amu_fdump_info; %page;%include amu_info; %page;%include azm_info; %page;%include ssu_rp_options; dcl 1 local_rpo like rp_options; %page;%include ssu_prompt_modes; %page;%include stack_frame; end analyze_multics;  azm_address_space_.pl1 07/28/87 0939.2rew 07/28/87 0924.3 199755 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-01-14,Parisek), approve(87-07-09,MCR7746), audit(87-07-20,Fawcett), install(87-07-28,MR12.1-1049): Call amu_$terminate_translation to free oldest allocated fdump temp segments when user's process_dir is found to be at least 75% full. (phx19335) END HISTORY COMMENTS */ azm_address_space_: proc (); return; /* not an entrypoint */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */ /* Assorted requests for analyze_multics. */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* 0) Created: 06/25/83 by B. Braun from the division of azm_misc_requests_ into smaller */ /* modules. This includes azm requests dealing with address spaces: select_dump, */ /* deadproc_mode (not a request yet), delete_dump, list_dumps, fdump_components */ /* */ /* 1) Modified: 08/10/84 by B. Braun to add $deadproc entry. */ /* 2) Modified: 09/26/84 by R. A. Fawcett to call azm_why$who when a fdump is found. */ /* 3) Modified: 01/11/85 by BLB to abort with no code after a call to amu_$deadproc_init. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl ( P_sci_ptr pointer, P_azm_info_ptr pointer ) parameter; /* Automatic */ dcl WHAT_ERF fixed bin; dcl af_sw bit (1) aligned; dcl already_translated bit(1); dcl alloted_quota fixed bin(18); dcl axp ptr init (null); dcl argl fixed bin (21); dcl argno fixed bin; dcl argp pointer; dcl axstring char (7) init (""); dcl brief_sw bit (1) init ("0"b); dcl code fixed bin (35); dcl configp ptr init (null); dcl cur_erf bit (1) init ("0"b); dcl del_cur_erf bit (1) init ("0"b); dcl del_erf bit (1) init ("0"b); dcl destroy_amu_ptr ptr; dcl dir_name char (168); dcl dir_sw bit (1) init ("0"b); dcl dp_path char(168); dcl dsegp ptr init (null); dcl dump_path char(168); dcl erf_name char (168); dcl erf_path char (168); dcl erfs_found bit (1) init ("0"b); dcl expand_ptr_sw bit (1) init ("0"b); dcl expand_sw bit (1) init ("0"b); /* "1"b = expand syserr binary data */ dcl first_erf bit (1) init ("0"b); dcl first_value_set bit (1) init ("0"b); dcl forward_search bit (1) init ("0"b); dcl frame_entry bit (1) init ("0"b); dcl hdr_printed bit (1) init ("0"b); dcl last fixed bin init (0); dcl last_erf bit (1) init ("0"b); dcl list_erfs bit (1) init ("0"b); dcl ll fixed bin init (0); dcl ln fixed bin init (0); dcl match_str char (256) var init (""); /* the syserr string to match on */ dcl nargs fixed bin; dcl next_erf bit (1) init ("0"b); dcl prev_erf bit (1) init ("0"b); dcl print_all_trans bit (1) init ("0"b); dcl print_erf_sw bit (1); dcl print_sw bit(1); dcl process_dir char(168); /* users process dir */ dcl quota_percent_flt float bin(18); /* alloted quota divided by quota_used */ dcl quota_percent_fix fixed bin(18); dcl quota_used fixed bin(18); /* used quota in pd */ dcl range_value_set bit (1) init ("0"b); dcl raw_syserr_data bit (1) init ("0"b); /* "1"b = print it in octal */ dcl ret_str char (168) var init (""); dcl rv_lth fixed bin (21); dcl rv_ptr ptr; dcl sci_ptr pointer; /* assorted info pointers */ dcl segln fixed bin (35) init (0); dcl slog_code fixed bin init (3); /* the syserr_code, default to =< 3 */ dcl sons_lvid bit(36); dcl start_configp ptr init (null); dcl struct_sw bit (1) init ("0"b); dcl tacc_sw fixed bin(1); dcl trp fixed bin(71); dcl tup bit(36) aligned; dcl why_erf bit (1) init ("0"b); /* Based */ dcl arg char (argl) based (argp); dcl rv_str char (rv_lth) varying based (rv_ptr); /* Constants */ /* Builtins */ dcl (addr, char, null, search, string, index) builtin; /* Conditions */ dcl cleanup condition; /* External Entries */ dcl amu_$deadproc_init entry (char(*), char (168), ptr, fixed bin (35)); dcl amu_$current_deadproc entry (ptr); dcl amu_$deadproc_name_af entry (ptr, ptr, fixed bin(21)); dcl amu_$fdump_mgr_cur_erf entry(ptr); dcl amu_$fdump_mgr_name_erf entry(ptr); dcl amu_$fdump_mgr_find_fdump entry (char(*), ptr, char(*), fixed bin, ptr, fixed bin(35)); dcl amu_$fdump_mgr_init_fdump entry (char (*), ptr, ptr, fixed bin (35)); dcl amu_$find_system_fdump entry (character (*), pointer, fixed binary (35)); dcl amu_$find_system_pdir entry (character (*), pointer, fixed binary (35)); dcl amu_$list_system_dumps entry (character (*), character (8) aligned, fixed bin, pointer, pointer, fixed binary (35)); dcl amu_$terminate_translation entry (ptr); dcl azm_why_$who entry (ptr, ptr, fixed bin(35)); dcl check_star_name_$path entry (char(*), fixed bin(35)); dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)); dcl get_pdir_ entry returns (char(168)); dcl hcs_$quota_read entry (char(*), fixed bin(18), fixed bin(71), bit(36) aligned, bit(36), fixed bin(1), fixed bin(18), fixed bin(35)); dcl ioa_ entry options (variable); dcl pathname_ entry (char(*), char(*)) returns(char(168)); dcl ssu_$abort_line entry options (variable); dcl ssu_$add_request_table entry (ptr, ptr, fixed bin, fixed bin(35)); dcl ssu_$arg_count entry (pointer, fixed bin, bit (1) aligned); dcl ssu_$arg_ptr entry (pointer, fixed bin, pointer, fixed bin (21)); dcl ssu_$delete_request_table entry (ptr, ptr, fixed bin(35)); dcl ssu_$get_subsystem_and_request_name entry (pointer) returns (char (72) varying); dcl ssu_$print_message entry() options(variable); dcl ssu_$return_arg entry (ptr, fixed bin, bit (1) aligned, ptr, fixed bin (21)); /* External Static */ dcl error_table_$badopt fixed bin (35) external static; dcl error_table_$noentry fixed bin (35) external static; dcl error_table_$nostars fixed bin (35) external static; dcl error_table_$too_many_args fixed bin (35) external static; dcl ssu_et_$request_table_not_found fixed bin (35) external static; dcl azm_request_table_$azm_request_table_ fixed bin external static; dcl azm_pdir_rq_table_$azm_pdir_rq_table_ fixed bin external static; %page; /*****************************************************************************/ azm_address_space_$list_dumps: entry (P_sci_ptr, P_azm_info_ptr); dcl dx fixed bin; dcl (fdump_sw, deadproc_sw) bit(1); dcl list_name char(168); dcl list_what fixed bin; call setup(); if nargs > 3 then do; code = error_table_$too_many_args; call ssu_$abort_line (sci_ptr, code, "^/Usage: lsd {PATH} {-ctl_args"); end; /* set defaults */ deadproc_sw = "0"b; fdump_sw = "0"b; list_what = LIST_FDUMPS; list_name = "*"; do argno = 1 to nargs; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if char (arg, 1) = "-" then do; if arg = "-fdump" | arg = "-fd" then fdump_sw = "1"b; else if arg = "-dp" | arg = "-deadproc" then deadproc_sw = "1"b; else call ssu_$abort_line (sci_ptr, error_table_$badopt, """^a"".", arg); end; else list_name = arg; end; if ^(fdump_sw | deadproc_sw) then fdump_sw = "1"b; if fdump_sw & deadproc_sw then list_what = LIST_ALL; else if deadproc_sw then list_what = LIST_PDIRS; else if fdump_sw then list_what = LIST_FDUMPS; system_dump_list_ptr = null(); on cleanup begin; if system_dump_list_ptr ^= null() then free system_dump_list; end; call amu_$list_system_dumps (list_name, SYSTEM_DUMP_LIST_VERSION_1, list_what, azm_info.area_ptr, system_dump_list_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Listing ^[fdumps^;pdirs^] ^[matching ^a^;^sfound by ""dumps"" search paths^].", fdump_sw, (search(list_name, "<>") ^= 0), list_name); do dx = 1 to system_dump_list.n_dumps; if system_dump_list.new_directory (dx) then call ioa_ ("Dumps in ^a:", system_dump_list.dir_name (dx)); call ioa_ ("^5x^a", system_dump_list.full_entryname (dx)); end; free system_dump_list; /* all done */ return; %page; /*****************************************************************************/ azm_address_space_$fdump_components: entry (P_sci_ptr, P_azm_info_ptr); sci_ptr = P_sci_ptr; call ssu_$abort_line (sci_ptr, 0, "This request has not been implemented yet."); return; %page; /*****************************************************************************/ azm_address_space_$delete_dump: entry (P_sci_ptr, P_azm_info_ptr); sci_ptr = P_sci_ptr; call ssu_$abort_line (sci_ptr, 0, "This request has not been implemented yet."); return; %page; /*****************************************************************************/ azm_address_space_$erf: entry (P_sci_ptr, P_azm_info_ptr); /* Select a new or previously translated ERF to peruse or delete. */ call setup; if nargs = 0 then do; if ^azm_info.flags.in_erf then call ssu_$abort_line (sci_ptr, 0, "No dump has been selected yet."); call amu_$fdump_mgr_cur_erf (amu_info_ptr); return; end; if nargs > 1 then do; code = error_table_$too_many_args; call ssu_$abort_line (sci_ptr, code, "^/Usage: sld NAME | -next | -prev | -last | -first"); return; end; first_erf, last_erf, prev_erf, next_erf, cur_erf, why_erf = "0"b; erf_name, dir_name, erf_path, dump_path = ""; WHAT_ERF = -1; do argno = 1 to nargs; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if index (arg, "-") = 1 then do; if arg = "-previous" | arg = "-prev" then do; WHAT_ERF = 2; prev_erf = "1"b; end; else if arg = "-nx" | arg = "-next" then do; WHAT_ERF = 3; next_erf = "1"b; end; else if arg = "-lt" | arg = "-last" then do; WHAT_ERF = 1; /* looking for newest */ last_erf = "1"b; end; else if arg = "-ft" | arg = "-first" then do; WHAT_ERF = 0; /* looking for oldest */ first_erf = "1"b; end; else do; call ssu_$abort_line (sci_ptr, error_table_$badopt, """^a"".", arg); end; end; else do; dump_path = arg; end; end; SDI_ptr = addr(SDI); SDI.version = SYSTEM_DUMP_INFO_VERSION_1; SDI.dump_dir_name, SDI.dump_seg_prefix, SDI.dump_name, SDI.dump_entry_format = ""; code = 0; if dump_path ^= "" then do; call check_star_name_$path (dump_path, code); if code > 0 then call ssu_$abort_line (sci_ptr, error_table_$nostars, "^a", dump_path); call amu_$find_system_fdump (dump_path, SDI_ptr, code); if code ^= 0 then do; if code = error_table_$noentry then call ssu_$abort_line (sci_ptr, code, "Looking for fdump ^a.", dump_path); else call ssu_$abort_line (sci_ptr, code, "^a", dump_path); end; /* got the erf, check if it's already translated */ already_translated = "0"b; if amu_info_ptr ^= null() then /* ensure ERF is not already translated */ call walk_chain((SDI.dump_name), amu_info_ptr, already_translated); if already_translated then do; print_erf_sw = "1"b; goto FOUND_ERF; end; else do; /* here we init the fdump */ goto INIT_FDUMP; end; end; /* Here we have to get a list of all fdumps and then determine the one wanted from the current one */ if WHAT_ERF >= 0 then do; if (next_erf | prev_erf) then do; if amu_info_ptr = null() then call ssu_$abort_line (sci_ptr, 0, "No fdump currently selected."); if amu_info.type ^= FDUMP_PROCESS_TYPE then call ssu_$abort_line (sci_ptr, 0, "No current fdump selected."); end; if amu_info_ptr = null() then erf_path = ""; else erf_path = pathname_((fdump_info.dump_dname), (fdump_info.dump_ename)); call amu_$fdump_mgr_find_fdump ((ssu_$get_subsystem_and_request_name (sci_ptr)), amu_info_ptr, erf_path, WHAT_ERF, SDI_ptr, code); if code ^= 0 then return; /* msg already printed */ end; already_translated = "0"b; if amu_info_ptr ^= null() then /* ensure ERF is not already translated */ call walk_chain((SDI.dump_name), amu_info_ptr, already_translated); if already_translated then do; print_erf_sw = "1"b; goto FOUND_ERF; end; INIT_FDUMP: /* Get the amount of used quota in user's process directory before attempting a dump translation. If at least 75% full then at least query user as to whether he/she still wants to continue. */ process_dir = get_pdir_ (); call hcs_$quota_read (process_dir, alloted_quota, trp, tup, sons_lvid, tacc_sw, quota_used, code); if code ^= 0 then call ssu_$print_message (sci_ptr, code, "Will continue..."); else do; quota_percent_flt = quota_used / alloted_quota; quota_percent_fix = quota_percent_flt*100; if quota_percent_fix >= 75 then do; destroy_amu_ptr = amu_info_ptr; do while (destroy_amu_ptr->amu_info.chain.prev ^= null); destroy_amu_ptr = destroy_amu_ptr->amu_info.chain.prev; end; call amu_$terminate_translation (destroy_amu_ptr); end; end; /* Ok will look for it */ call amu_$fdump_mgr_init_fdump ((ssu_$get_subsystem_and_request_name (sci_ptr)), SDI_ptr, amu_info_ptr, code); if code ^= 0 then return; /* message already printed */ print_erf_sw = "1"b; string (azm_info.flags) = ""b; /* chain this in at the end */ call add_to_chain(azm_info.aip, amu_info_ptr); /* find the process that is indicated by scs$trouble_pid */ /* azm_why_$who will return a 0 code if it could find and set to */ /* the trouble_pid if not able the default will not change and */ /* the error_table_$action_not_preformed will be returned but we */ /* don't care and the code will be set to zero. */ call azm_why_$who (sci_ptr,amu_info_ptr,code); code = 0; FOUND_ERF: call set_azm_info (print_erf_sw, "0"b); /* change request tables */ call ssu_$delete_request_table (sci_ptr, addr(azm_pdir_rq_table_$azm_pdir_rq_table_), code); if code = ssu_et_$request_table_not_found then; /* If this code is returned, we must not add the table "azm_request_table_". If we do, all future calls to add the request table "pdir_rq_table_" will fail, although code returned is 0. */ else do; call ssu_$add_request_table (sci_ptr, addr(azm_request_table_$azm_request_table_), 1, code); if code ^= 0 then call ssu_$print_message(sci_ptr, code, "Adding azm_request_table_."); end; return; %page; /*****************************************************************************/ azm_address_space_$deadproc: entry (P_sci_ptr, P_azm_info_ptr); /* Select a new or previously translated SAVED PROC (deadproc) to peruse or delete. */ dcl dp_name char(168); call setup(); print_sw = "0"b; if nargs = 0 then do; if ^azm_info.flags.saved_proc then call ssu_$abort_line (sci_ptr, 0, "No dead process selected."); call amu_$current_deadproc (amu_info_ptr); return; end; else if nargs > 1 then do; code = error_table_$too_many_args; call ssu_$abort_line (sci_ptr, code, "^/Usage: sldp NAME"); return; end; dp_name, dp_path, dir_name = ""; code = 0; already_translated = "0"b; call ssu_$arg_ptr (sci_ptr, 1, argp, argl); dp_path = arg; code = 0; call check_star_name_$path (dp_path, code); if code > 0 then call ssu_$abort_line (sci_ptr, error_table_$nostars, "^a", dp_path); if amu_info_ptr ^= null() then do; /* check to see if already translated */ /* call parse_dump_path (dp_path, dp_name, dir_name);*/ code = 0; call expand_pathname_$add_suffix (dp_path, PDIR_SUFFIX, dir_name, dp_name, code); if code ^= 0 then goto FIND_NAME; call walk_chain(dp_name, amu_info_ptr, already_translated); if already_translated then goto FOUND_DP; end; FIND_NAME: SDI.version = SYSTEM_DUMP_INFO_VERSION_1; SDI.dump_dir_name, SDI.dump_seg_prefix, SDI.dump_name, SDI.dump_entry_format = ""; call amu_$find_system_pdir (dp_path, addr (SDI), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", dp_path); call walk_chain((SDI.dump_name), amu_info_ptr, already_translated); if already_translated then goto FOUND_DP; call amu_$deadproc_init ((ssu_$get_subsystem_and_request_name (sci_ptr)), pathname_(SDI.dump_dir_name, (SDI.dump_name)), amu_info_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, 0); /* message already printed */ call add_to_chain(azm_info.aip, amu_info_ptr); string (azm_info.flags) = ""b; FOUND_DP: call set_azm_info ("1"b, af_sw); /* change request tables */ call ssu_$delete_request_table (sci_ptr, addr(azm_request_table_$azm_request_table_), (0)); call ssu_$add_request_table (sci_ptr, addr(azm_pdir_rq_table_$azm_pdir_rq_table_), 1, code); if code ^= 0 then call ssu_$print_message(sci_ptr, code, "Adding azm_pdir_rq_table_."); return; /* end "deadproc" request */ %page; /*****************************************************************************/ add_to_chain: proc(start_ptr, new_ptr); dcl new_ptr ptr; dcl start_ptr ptr; dcl temp_ptr ptr; temp_ptr = start_ptr; if temp_ptr ^= null then do; /* first walk chain to last amu_info in chain */ do while (temp_ptr -> amu_info.chain.next ^= null); temp_ptr = temp_ptr -> amu_info.chain.next; end; end; /* Now chain new one on */ new_ptr -> amu_info.chain.prev = temp_ptr; new_ptr -> amu_info.chain.next = null (); if temp_ptr ^= null () then temp_ptr -> amu_info.chain.next = new_ptr; end add_to_chain; %page; /*****************************************************************************/ set_azm_info: proc (print_it, af_sw); dcl print_it bit (1); dcl af_sw bit(1) aligned; azm_info.aip = amu_info_ptr; if trans_selected () then do; if amu_info.type = FDUMP_TYPE | amu_info.type = FDUMP_PROCESS_TYPE then do; azm_info.erf_name = fdump_info.erf_name; azm_info.flags.in_erf = "1"b; if print_it then call amu_$fdump_mgr_name_erf (amu_info_ptr); end; else if (amu_info.type = SAVED_PROC_TYPE) then do; azm_info.erf_name = amu_info.fdump_info_ptr -> old_uid_table.dp_name; azm_info.flags.saved_proc = "1"b; if af_sw then call amu_$deadproc_name_af (amu_info_ptr, rv_ptr, rv_lth); else call amu_$current_deadproc (amu_info_ptr); end; end; else azm_info.erf_name = ""; end set_azm_info; %page; /*****************************************************************************/ setup: proc; sci_ptr = P_sci_ptr; azm_info_ptr = P_azm_info_ptr; amu_info_ptr = azm_info.aip; call ssu_$return_arg (sci_ptr, nargs, af_sw, rv_ptr, rv_lth); if af_sw then rv_str = ""; else call ssu_$arg_count (sci_ptr, nargs, af_sw); allocate_uid_hash = 0; /* To avoid the compiler warning */ end setup; %page; /*****************************************************************************/ trans_selected: proc () returns (bit (1)); if amu_info_ptr = null () then return ("0"b); return ("1"b); end trans_selected; %page; /*****************************************************************************/ walk_chain: proc(dump_name, a_chain_ptr, found); dcl dump_name char(*); dcl a_chain_ptr ptr; dcl found bit(1); /* This routine walks the amu_info chain to determine if the dump is already translated. If so, found is true, else found is false. dump_name name of dump to look for (input) a_chain_ptr chain_ptr, if found the ptr of the found translation is returned. (input/output) found true if already translated (output) */ dcl temp_ptr ptr; dcl chain_ptr ptr; chain_ptr = a_chain_ptr; found = "0"b; if chain_ptr = null then return; /* no chain to walk exists */ /* find first trans */ do while (chain_ptr -> amu_info.chain.prev ^= null); chain_ptr = chain_ptr -> amu_info.chain.prev; end; do while (chain_ptr ^= null & ^found); /* now walk chain */ temp_ptr = chain_ptr -> amu_info.fdump_info_ptr; if chain_ptr -> amu_info.type = FDUMP_TYPE | chain_ptr -> amu_info.type = FDUMP_PROCESS_TYPE then do; if temp_ptr -> fdump_info.erf_name = dump_name then do; /* Ok I found it */ a_chain_ptr = chain_ptr; found = "1"b; end; end; else if chain_ptr -> amu_info.type = SAVED_PROC_TYPE then do; if temp_ptr -> old_uid_table.dp_name = dump_name then do; /* Ok I found it */ a_chain_ptr = chain_ptr; found = "1"b; end; end; chain_ptr = chain_ptr -> amu_info.chain.next; end; /* end loop */ end walk_chain; %page; %include amu_info; %page; %include amu_fdump_info; %page; %include amu_old_uid_table; %page; %include amu_translation; %page; %include azm_info; %page; %include system_dump_info; dcl 1 SDI aligned like system_dump_info; dcl SDI_ptr ptr; end azm_address_space_;  azm_display_am_.pl1 11/19/84 1143.5rew 11/15/84 1440.1 124470 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ azm_display_am_: proc (P_sci_ptr, P_amu_info_ptr, prds_sw, sdw_sw, ptw_sw, only_fulls, sdw_segno, ptw_pageno, P_code); /* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */ /* Associative memory display program for analyze_multics. Taken from ol_dumps display_am by Rich Coppola Sept 1982. */ /* Parameters */ dcl P_amu_info_ptr ptr; dcl P_sci_ptr ptr; dcl P_code fixed bin (35); dcl prds_sw bit (1); /* "1"b = do AMs from prds */ dcl sdw_sw bit (1); /* "1"b = do SDWs only */ dcl ptw_sw bit (1); /* "1"b = do PTWs only */ dcl only_fulls bit (1); /* "1"b = display only full entries */ dcl sdw_segno fixed bin; /* display entries that have this segno */ dcl ptw_pageno fixed bin; /* display entries that have this pageno */ /* Automatic Data */ dcl DPS8xxM bit (1); /* "1"b = DPS8xxM type CPU */ dcl IDX fixed bin; dcl code fixed bin (35); dcl data_buf_ptr ptr init (null); dcl dup_entry (0:63) bit (1) unal; dcl first fixed bin (18); dcl first_entry fixed bin; dcl first_level fixed bin; dcl flag_string char (7); dcl i fixed bin; dcl idx fixed bin; dcl index_changed bit (1) init ("0"b); dcl j fixed bin; dcl last_entry fixed bin; dcl last_level fixed bin; dcl nregs fixed bin; /* # of regs 16/64 */ dcl ptws_printed bit (1) init ("0"b); dcl pageno_sw bit (1) init ("0"b); dcl ptr_ptr ptr init (null); dcl ptw_hdr_printed bit (1); dcl ptw_level_printed bit (1) init ("0"b); dcl ptw_ptrs_ptr ptr; dcl ptw_regs_ptr ptr; dcl range fixed bin (18); dcl reg_ptr ptr init (null); dcl sci_ptr ptr; dcl sdw_hdr_printed bit (1); dcl sdw_level_printed bit (1) init ("0"b); dcl sdw_ptrs_ptr ptr; dcl sdw_regs_ptr ptr; dcl sdws_printed bit (1) init ("0"b); dcl seg_ptr pointer; dcl segno fixed bin; dcl segno_sw bit (1) init ("0"b); dcl temp_ptr ptr init (null); dcl usage_string char (8); /* Constants */ dcl AM_LEVEL (1:4) char (1) int static options (constant) init ("A", "B", "C", "D"); /* levels of dps8 AMs */ /* Based */ dcl last_three_sets bit (48 * 36) based; dcl 1 ptw_regs (0:63) aligned like amptwreg based (ptw_regs_ptr); dcl 1 ptw_ptrs (0:63) aligned like amptwptr based (ptw_ptrs_ptr); dcl 1 sdw_regs (0:63) aligned like amsdwreg based (sdw_regs_ptr); dcl 1 sdw_ptrs (0:63) aligned like amsdwptr based (sdw_ptrs_ptr); /* External entries */ dcl amu_$definition_ptr entry (ptr, char (*), char (*), fixed bin (35)) returns (ptr); dcl amu_$do_translation entry (ptr, fixed bin, ptr, fixed bin (18), fixed bin (18), fixed bin (35)); dcl amu_$fdump_mpt_temp_change_idx entry (ptr, fixed bin); dcl amu_$fdump_mpt_revert_idx entry (ptr); dcl amu_$get_name entry (ptr, ptr) returns (char (*)); dcl amu_$get_name_no_comp entry (ptr, ptr) returns (char (*)); dcl amu_$return_val_per_process entry (ptr, fixed bin) returns (bit (1)); dcl ssu_$get_temp_segment entry (ptr, char(*), ptr); dcl ssu_$release_temp_segment entry (ptr, ptr); dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl (addr, addrel, baseno, binary, baseptr, divide, fixed, lbound, null, rel) builtin; dcl any_other condition; %page; amu_info_ptr = P_amu_info_ptr; sci_ptr = P_sci_ptr; P_code = 0; data_buf_ptr = null (); on condition (any_other) go to done; call set_up; if sdw_sw then do; call display_sdw; if sdws_printed = "0"b then do; if segno_sw then /* none printed and, */ /* if we were looking for only one */ call ioa_ ("^/A valid entry for SEGNO ^o not found in SDWAM from ^[Dump^;prds$am_data^].", sdw_segno, ^prds_sw); end; end; if ptw_sw then do; call display_ptw; if ptws_printed = "0"b then do; if (pageno_sw | sdw_sw) then do;/* same as for SDWs */ if ptw_pageno = -1 then ptw_sw = "0"b; call ioa_ ("^/A valid entry for ^[PAGENO ^o ^;^s^]^[of ^]^[ SEGNO ^o ^;^s^]not found in PTWAM from ^[Dump^;prds$am_data^].", ptw_sw, ptw_pageno, (ptw_sw & sdw_segno ^= -1), sdw_sw, sdw_segno, ^prds_sw); end; end; end; done: if data_buf_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, data_buf_ptr); return; %page; display_ptw: proc; first_entry = 0; last_entry = 15; if DPS8xxM then do; first_level = 1; last_level = 4; end; else do; first_level = 1; last_level = 1; end; call validate_am_ptw; if ptw_pageno ^= -1 then pageno_sw = "1"b; if sdw_segno ^= -1 then segno_sw = "1"b; ptw_level_printed, ptw_hdr_printed = "0"b; do IDX = first_level to last_level; ptw_level_printed = "0"b; do idx = first_entry to last_entry; seg_ptr = addrel (baseptr (binary (ptw_ptrs (idx).pointer, 15)), (binary (ptw_ptrs (idx).pageno, 12) * 16)) ; /* get a pointer to the segment, so we can get its name */ if (only_fulls & ^ptw_ptrs (idx).valid) then go to bypass_ptw; if (segno_sw & (fixed (ptw_ptrs (idx).pointer, 15) ^= sdw_segno)) then go to bypass_ptw; if pageno_sw then if divide (binary (ptw_ptrs (idx).pageno, 12), 16, 12, 0) ^= ptw_pageno then go to bypass_ptw; if ^DPS8xxM then call ioa_$rsnnl ("^6x^2d", usage_string, (0), binary (ptw_ptrs (idx).usage, 4)); else call ioa_$rsnnl ("^2x^6b", usage_string, (0), ptw_ptrs (idx).usage); if ptw_hdr_printed = "0"b then do; call ioa_ ("^/PTW Associative Memory ^[at the time of the dump^;at prds$am_data^].", ^prds_sw); call ioa_ (" ADDRESS^3xM^2xF/E USAGE_CT SEG # PAGE SEG_NAME|OFFSET"); ptw_hdr_printed = "1"b; end; if (DPS8xxM & ^ptw_level_printed) then do; call ioa_ ("LEVEL [^a]", AM_LEVEL (IDX)); ptw_level_printed = "1"b; end; call ioa_ ( "^8o^2x^[yes^;no ^]^2x^[F^;E^]^2x^8a ^5o ^4o ^[^a^;^s N/A^]^[^/^-*** POSSIBLE DUPLICATE ENTRY ***^]" , binary ((ptw_regs (idx).addr || "000000"b), 24), ptw_regs (idx).modif, ptw_ptrs (idx).valid, usage_string, binary (ptw_ptrs (idx).pointer, 15), divide (binary (ptw_ptrs (idx).pageno, 12), 16, 12, 0), ptw_ptrs (idx).valid, /* skip the naming if this PTWAM entry is empty */ amu_$get_name (amu_info_ptr, seg_ptr), dup_entry (idx)); ptws_printed = "1"b; bypass_ptw: end; first_entry = last_entry + 1; last_entry = first_entry + 15; end; return; end display_ptw; %page; display_sdw: proc; first_entry = 0; last_entry = 15; if DPS8xxM then do; first_level = 1; last_level = 4; end; else do; first_level = 1; last_level = 1; end; call validate_am_sdw; if sdw_segno ^= -1 then segno_sw = "1"b; sdw_level_printed, sdw_hdr_printed = "0"b; do IDX = first_level to last_level; sdw_level_printed = "0"b; do idx = first_entry to last_entry; if (only_fulls & ^sdw_ptrs (idx).valid) then go to bypass_sdw; if (segno_sw & (fixed (sdw_ptrs (idx).pointer, 15) ^= sdw_segno)) then go to bypass_sdw; call ioa_$rsnnl ("^[R^; ^]^[E^; ^]^[W^; ^]^[P^; ^]^[U^; ^]^[G^; ^]^[C^; ^]", flag_string, (0), /* generate the REWPUGC string */ sdw_regs (idx).read, sdw_regs (idx).execute, sdw_regs (idx).write, sdw_regs (idx).privileged, sdw_regs (idx).unpaged, sdw_regs (idx).entry_bound_sw, sdw_regs (idx).cache); if ^DPS8xxM then call ioa_$rsnnl ("^6x^2d", usage_string, (0), binary (sdw_ptrs (idx).usage, 4)); else call ioa_$rsnnl ("^2x^6b", usage_string, (0), sdw_ptrs (idx).usage); temp_ptr = baseptr (binary (sdw_ptrs (idx).pointer, 15)); if sdw_hdr_printed = "0"b then do; call ioa_ ("^/SDW Associative Memory ^[at the time of the dump^;at prds$am_data^].", ^prds_sw); call ioa_ (" ADDRESS^2xRINGS^2xBOUND^2xREWPUGC^4xCL F/E USAGE-CT SEG # SEG_NAME"); sdw_hdr_printed = "1"b; end; if (DPS8xxM & ^sdw_level_printed) then do; call ioa_ ("LEVEL [^a]", AM_LEVEL (IDX)); sdw_level_printed = "1"b; end; call ioa_ ( "^8o^2x^1.3b,^1.3b,^1.3b ^6o^2x^7a ^[^5o^;^s^4x-^]^2x^[F^;E^]^2x^8a ^5o ^[^a^;^s N/A^]^[^/^-*** POSSIBLE DUPLICATE ENTRY ***^]" , binary (sdw_regs (idx).addr, 24), sdw_regs (idx).r1, sdw_regs (idx).r2, sdw_regs (idx).r3, binary ((sdw_regs (idx).bound || "0000"b), 18), flag_string, ((^sdw_regs (idx).entry_bound_sw) & sdw_regs (idx).execute), /* skip next if there is none */ binary (sdw_regs (idx).cl, 14), sdw_ptrs (idx).valid, usage_string, binary (sdw_ptrs (idx).pointer, 15), sdw_ptrs (idx).valid, /* skip the naming if the entry isn't valid */ amu_$get_name_no_comp (amu_info_ptr, temp_ptr), dup_entry (idx)); sdws_printed = "1"b; bypass_sdw: end; first_entry = last_entry + 1; last_entry = first_entry + 15; end; return; end display_sdw; %page; get_data_: proc (data_ptr, seg, word, number); dcl seg fixed bin; dcl data_ptr ptr; dcl (word, number) fixed bin (18); if ^amu_$return_val_per_process (amu_info_ptr, seg) then do; index_changed = "1"b; call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, lbound (fdump_process_table.array, 1)); end; call amu_$do_translation (amu_info_ptr, seg, data_ptr, word, number, code); if index_changed = "1"b then do; call amu_$fdump_mpt_revert_idx (amu_info_ptr); index_changed = "0"b; end; end get_data_; %page; set_up: proc; code = 0; if ^prds_sw then do; /* do AMs from 'dump' */ dumpptr = fdump_info.dump_seg_ptr (0); sdw_regs_ptr = addr (dump.amsdwregs); sdw_ptrs_ptr = addr (dump.amsdwptrs); ptw_regs_ptr = addr (dump.amptwregs); ptw_ptrs_ptr = addr (dump.amptwptrs); end; else do; /* do AMs from PRDS */ range = 512; /* need 512 words */ temp_ptr = amu_$definition_ptr (amu_info_ptr, "prds", "am_data", code); if code ^= 0 then do; P_code = code; return; end; segno = fixed (baseno (temp_ptr), 17); first = fixed (rel (temp_ptr), 18); call ssu_$get_temp_segment (sci_ptr, "azm_display_am_", data_buf_ptr); call get_data_ (data_buf_ptr, segno, first, range); /* ensure data is contigous */ if code ^= 0 then do; P_code = code; if data_buf_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, data_buf_ptr); return; end; ptw_regs_ptr = data_buf_ptr; ptw_ptrs_ptr = addrel (ptw_regs_ptr, 64); sdw_regs_ptr = addrel (ptw_ptrs_ptr, 64); sdw_ptrs_ptr = addrel (sdw_regs_ptr, 128); end; temp_ptr = addrel (ptw_regs_ptr, 16); /* base to 2'nd set of regs */ if temp_ptr -> last_three_sets = "0"b then do; /* if second set is zero then */ nregs = 15; /* AMs are from a l68 */ DPS8xxM = "0"b; end; else do; /* No, they are from a DPS8M */ nregs = 63; DPS8xxM = "1"b; end; return; end set_up; %page; validate_am_ptw: proc; dup_entry (*) = "0"b; do i = 0 to nregs - 1; do j = i + 1 to nregs; if (ptw_ptrs (i).valid & ptw_ptrs (j).valid) then do; if ptw_regs (i).addr = ptw_regs (j).addr then do; dup_entry (i) = "1"b; dup_entry (j) = "1"b; end; else if ptw_ptrs (i).usage = ptw_ptrs (j).usage then do; if ^DPS8xxM then do; /* if its not a dps8 */ dup_entry (i) = "1"b; dup_entry (j) = "1"b; end; end; else if (ptw_ptrs (i).pointer = ptw_ptrs (j).pointer) & (ptw_ptrs (i).pageno = ptw_ptrs (j).pageno) then do; dup_entry (i) = "1"b; dup_entry (j) = "1"b; end; if (dup_entry (i) & dup_entry (j)) then do; if ptw_regs (i).addr = ptw_regs (j).addr then if ptw_ptrs (i).pointer ^= ptw_ptrs (j).pointer then do; if DPS8xxM then go to cancel_dup_ptw; if ptw_ptrs (i).usage ^= ptw_ptrs (j).usage then do; cancel_dup_ptw: dup_entry (i), dup_entry (j) = "0"b; end; end; end; end; end; end; return; end validate_am_ptw; %page; validate_am_sdw: proc; dup_entry (*) = "0"b; do i = 0 to nregs - 1; do j = i + 1 to nregs; if (sdw_ptrs (i).valid & sdw_ptrs (j).valid) then do; if sdw_regs (i).addr = sdw_regs (j).addr then do; dup_entry (i) = "1"b; dup_entry (j) = "1"b; end; else if sdw_ptrs (i).pointer = sdw_ptrs (j).pointer then do; dup_entry (i) = "1"b; dup_entry (j) = "1"b; end; else if sdw_ptrs (i).usage = sdw_ptrs (j).usage then do; if ^DPS8xxM then do; /* if its not a dps8 */ dup_entry (i) = "1"b; /* for dps8 it is LRU not usage ctr */ dup_entry (j) = "1"b; end; end; if (dup_entry (i) & dup_entry (j)) then do; if sdw_regs (i).addr = sdw_regs (j).addr then if sdw_regs (i).bound = sdw_regs (j).bound then if (sdw_regs (i).r2 & sdw_regs (i).r3) ^= (sdw_regs (j).r2 & sdw_regs (j).r3) then if sdw_ptrs (i).pointer ^= sdw_ptrs (j).pointer then do; if DPS8xxM then go to cancel_dup_sdw; if sdw_ptrs (i).usage ^= sdw_ptrs (j).usage then do; cancel_dup_sdw: dup_entry (i), dup_entry (j) = "0"b; end; end; end; end; end; end; return; end validate_am_sdw; %page; %include assoc_mem; %page; %include sdw; %page; %include ptw; %page; %include amu_info; %page; %include amu_hardcore_info; %page; %include bos_dump; %page; %include amu_fdump_info; end azm_display_am_;  azm_display_fdump_events.pl1 08/08/88 1128.5r w 08/08/88 1115.1 535869 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-06-09,Farley), approve(87-07-09,MCR7746), audit(87-07-20,Fawcett), install(87-07-28,MR12.1-1049): Corrected bug in setting exp_seg_name. 2) change(86-10-08,Farley), approve(87-07-09,MCR7746), audit(87-07-20,Fawcett), install(87-07-28,MR12.1-1049): Added quentry.used to diskq_data for flagging incomplete "(I)" I/O. 3) change(87-01-06,Parisek), approve(87-07-09,MCR7746), audit(87-07-20,Fawcett), install(87-07-28,MR12.1-1049): Add functionality of matching and excluding strings on event strings. 4) change(87-01-09,Parisek), approve(87-07-09,MCR7746), audit(87-07-20,Fawcett), install(87-07-28,MR12.1-1049): Check processor_tag value before referencing it in a function. Previously too large a value would cause an OOB error. 5) change(87-01-21,Parisek), approve(87-07-09,MCR7746), audit(87-07-20,Fawcett), install(87-07-28,MR12.1-1049): Check validity of disk device name and device number before assigning an auto variable to them, then displaying such. 6) change(87-07-09,Parisek), approve(87-07-09,MCR7746), audit(87-07-20,Fawcett), install(87-07-28,MR12.1-1049): Changed declaration of proc_exists_mask from bit(36) to bit(8) to prevent stringsize conditions. 7) change(88-04-04,Parisek), approve(88-04-21,MCR7877), audit(88-07-08,Farley), install(88-07-12,MR12.2-1055): Changed disk_queue event processing to only process events of interest when processing by time. END HISTORY COMMENTS */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend */ azm_display_fdump_events: proc (P_sci_ptr, P_amu_info_ptr, num_events, delta_time, long_report, match_info_ptr, code); /* Routine to scan an FDUMP for interesting time-stamped events, sort these events by time (reverse order), and print them. The following events are considered as interesting: Machine Conditions (from BCE, prds, pds, mc_trace_buf) Traffic Control State Change Time Syserr Messages (from both syserr_data and syserr_log) Fim Frames in any stack Connects by device Disk queues (long report only) An array of pointers to FDUMP is passed as a parameter--this array is in order by FDUMP component (0, 1, 2, ...). Also passed are pointers to copies of certain segments from the FDUMP (these are not within the FDUMP itself, but copied from it. Modification history: 81-03-15, J. Bongiovanni: Initial coding 81-04-21, Rich Coppola: Added expanded path name/rel offset 81-07-10, J. Bongiovanni; Added connects, by device 82-01-04, J. Bongiovanni: Added disk queues, mc_trace_buf 82-05-22, Rich Coppola: Modified for new ASTE 82-07-30, J. Bongiovanni: Modified for new time format in disk Q 82-11-13, Rich Coppola: Modified for analyze_multics 83-02-10, Rich Fawcett: Modified to reduce space used. 83-01-24, B. Braun: Modified for P. Farley's change to check that all eight words of SCU data are zero before assuming no scu data was stored. 84-01-19, BLB: Fix so events request -last and -time work (phx16720) 84-10-01, R. A. Fawcett: Added fault_tag_1 handler to walk_stack 84-10-02, R. A. Fawcett: Changed to use the info from the "new" disk_dim. 84-10-08, R. A. Fawcett: Changed walk_stack to use valid_fim_ptr 84-12-14, W. Olin Sibert: Converted syserr stuff for new format logs */ /* Parameter */ dcl P_amu_info_ptr ptr; dcl P_sci_ptr ptr; dcl num_events fixed bin; /* number of events to print */ dcl delta_time fixed bin (71); /* interval of interest in microseconds */ dcl long_report bit (1); /* ON=>long report format, OFF=>1 line/event */ dcl good_match bit (1); /* used when calling mh_or_ex proc */ dcl match_info_ptr ptr; /* ptr to match/exclude strings */ dcl temp_string char (128) varying; /* temp for checking matches or exclusions */ dcl temp_time char (32) varying; /* temp time stamp for matches or exclusions */ dcl tsl fixed bin (21); /* length of temp_string */ dcl code fixed bin (35); dcl new_disk_dim_sw bit (1); /* Automatic */ dcl apt_array_p ptr; dcl apt_inx fixed bin; dcl apt_proc_found bit (1); dcl bmp ptr init (null); dcl bound_interceptors_ptr ptr; dcl cur_date_time char (17); dcl definitions_ptr ptr; dcl diskq_datap ptr; dcl dom fixed bin; dcl DOM pic "99"; dcl dow fixed bin; dcl dump_ptrs ptr; dcl dump_seginx fixed bin; dcl dump_segno fixed bin; dcl earliest_recorded_time fixed bin (71); dcl earliest_time fixed bin (71); dcl event_inx fixed bin; dcl events_by_time bit(1); dcl events_printed fixed bin; dcl eventsp ptr; dcl first_print bit (1); dcl 1 hard_ptr_space like hardcore_cur; dcl hr fixed bin; dcl HR pic "z9"; dcl 1 interesting_segs (N_INTERESTING_SEGS) aligned, 2 segno fixed bin (18) init ((N_INTERESTING_SEGS) - 1), 2 process_this_seg bit (1) init ((N_INTERESTING_SEGS) (1)"1"b), 2 handler entry (bit (1) aligned) variable init ( process_prds, process_pds, process_tc_data, process_syserr_data, setup_from_scs, process_inzr_stk0, process_iom_data, process_disk_queue, copy_pvt, process_mc_trace_buf); dcl last_date_time char (17); dcl last_sec fixed bin; dcl last_segno fixed bin; dcl micsec fixed bin (71); dcl MICSEC pic "999999"; dcl minute fixed bin; dcl MIN pic "99"; dcl mon fixed bin; dcl MON pic "99"; dcl max_events fixed bin; dcl nametbl_ptr ptr; dcl prds_processor bit (8) unal; dcl proc_no fixed bin; dcl process_number fixed bin; dcl range fixed bin (18); dcl sci_ptr ptr; dcl sec fixed bin; dcl SEC pic "99"; dcl seg_found bit (1); dcl seginx fixed bin; dcl segp ptr; dcl sortp ptr; dcl sortinx fixed bin; dcl sortinx1 fixed bin; dcl sortinxt fixed bin; dcl stack_found bit (1); dcl stack_inx fixed bin; dcl stack_segs (0:7) fixed bin; dcl temp_alloc_p ptr; dcl temp_seg_data_p ptr; dcl 1 translation_space like translation; dcl tsegp ptr; dcl words_copied fixed bin (18); dcl yr fixed bin; dcl YR pic "99"; /* Static */ dcl CPU_TAG char (8) init ("abcdefgh") int static options (constant); dcl IOM_TAG char (4) init ("ABCD") int static options (constant); dcl MYNAME char (24) init ("azm_display_fdump_events") int static options (constant); dcl N_INTERESTING_SEGS fixed bin init (10) int static options (constant); dcl MC_TRACE_BUF fixed bin init (10) int static options (constant); dcl interesting_segname (N_INTERESTING_SEGS) char (32) int static options (constant) init ( "prds", "pds", "tc_data", "syserr_data", "scs", "inzr_stk0", "iom_data", "disk_seg", "pvt", ""); /* Index of mc_trace_buf */ /* Based */ dcl 1 temp_seg_data aligned based (temp_seg_data_p), /* info on temp segs allocated */ 2 n_temp_segs fixed bin, /* number temp segs allocated this way */ 2 temp_segp (0 refer (n_temp_segs)) ptr; /* array of pointers to allocated temp segs */ dcl 1 time_stamped_events aligned based (eventsp), /* events of interest from FDUMP */ 2 n_events fixed bin, /* number of events found */ 2 events (0 refer (n_events)), 3 time_stamp fixed bin (71), /* time of event */ 3 delete_on_duplicate_time bit (1), /* ON => delete this event if time the same as another */ 3 deleted bit (1), /* ON => this event deleted */ 3 event_struct_ptr ptr, /* structure of interest to event */ 3 event_display entry (char (*), ptr, fixed bin) variable, /* routine to print event */ 3 process_number fixed bin, /* process number in FDUMP */ 3 apte_offset bit (18), /* APTE offset or "0"b */ 3 added_info char (40) unal; /* other data to be printed */ dcl 1 apt_array aligned based (apt_array_p), /* used to translate apte offset to proc number */ 2 n_aptes fixed bin, 2 apt_desc (0 refer (n_aptes)) aligned, 3 offset bit (18) unal, /* offset of apte in tc_data */ 3 procn fixed bin (17) unal; /* process number in FDUMP */ dcl 1 diskq_data aligned based (diskq_datap), /* extract of disk queue/devtab info */ 2 pvtx fixed bin, 2 io_type fixed bin, 2 coreadd fixed bin (25), 2 sector fixed bin, 2 cylinder fixed bin, 2 used bit (1); dcl 1 indirect_sort_array aligned based (sortp), /* used for sorting time_stamped_events */ 2 sort_index (262144) fixed bin (18); /* Entry */ dcl amu_$definition_offset entry (ptr, char (*), char (*), fixed bin (35)) returns (fixed bin (18)); dcl amu_$do_translation entry (ptr, fixed bin, ptr, fixed bin (18), fixed bin (18), fixed bin (35)); dcl amu_$error_for_caller entry () options (variable); dcl amu_$fdump_mpt_temp_change_idx entry (ptr, fixed bin); dcl amu_$fdump_mpt_revert_idx entry (ptr); dcl amu_$get_name entry (ptr, ptr) returns (char (*)); dcl amu_$hardcore_info_set_cur_ptrs entry (ptr, ptr); dcl amu_$return_val_per_process entry (ptr, fixed bin) returns (bit (1)); dcl amu_$slt_search_seg_ptr entry (ptr, ptr, char (32), ptr, fixed bin (35)); dcl match_strings_$free entry (ptr); dcl match_strings_$test entry (ptr, char (*)) returns (bit (1) aligned); dcl ssu_$get_temp_segment entry (ptr, char(*), ptr); dcl ssu_$print_message entry() options(variable); dcl ssu_$release_temp_segment entry (ptr, ptr); dcl ( ioa_, ioa_$nnl, ioa_$rsnnl ) entry options (variable); dcl sys_info$max_seg_size fixed bin (35) ext static; dcl decode_clock_value_$date_time entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, char (3), fixed bin (35)); /* Condition */ dcl cleanup condition; /* Builtin */ dcl (addr, addrel, baseno, baseptr, bin, clock, convert, currentsize, divide, fixed, hbound, index, lbound, length, min, mod, null, pointer, ptr, rel, reverse, rtrim, size, string, substr, unspec) builtin; %page; /* Setup pointers and cleanup handler */ amu_info_ptr = P_amu_info_ptr; sci_ptr = P_sci_ptr; hardcore_cur_ptr = addr (hard_ptr_space); call amu_$hardcore_info_set_cur_ptrs (amu_info_ptr, hardcore_cur_ptr); dump_ptrs, dumpptr = fdump_info.dump_seg_ptr (0); sltp = hardcore_cur.sltp; nametbl_ptr = hardcore_cur.sltntp; definitions_ptr = hardcore_cur.defp; temp_alloc_p = null (); temp_seg_data_p = null (); eventsp, tsegp, pvtp = null (); temp_string, temp_time = ""; tsl = 0; good_match = ""b; on cleanup call cleanit; /* Initialize temporary segment allocation */ call ssu_$get_temp_segment (sci_ptr, MYNAME, temp_seg_data_p); eventsp = allocate_temp_seg (); tsegp = allocate_temp_seg (); /* Find segment numbers of all interesting segments */ do seginx = 1 to N_INTERESTING_SEGS; if interesting_segname (seginx) ^= "" then do; call amu_$slt_search_seg_ptr (hardcore_cur.sltp, hardcore_cur.sltntp, interesting_segname (seginx), segp, code); if code = 0 then interesting_segs.segno (seginx) = bin (baseno (segp), 18); else call amu_$error_for_caller ((null ()), code, MYNAME, "^a not found in dump", interesting_segname (seginx)); end; end; %page; prds_processor = "11111111"b; call amu_$slt_search_seg_ptr (hardcore_cur.sltp, hardcore_cur.sltntp, "bound_interceptors", bound_interceptors_ptr, code); if code ^= 0 then bound_interceptors_ptr = null (); new_disk_dim_sw = "1"b; stack_segs (*) = -1; proc_no = 0; last_segno = -1; earliest_recorded_time = clock (); /* dump must be earlier than this */ if num_events = -1 then events_by_time = "1"b; else events_by_time = "0"b; apt_array_p = allocate_temp_seg (); apt_array.n_aptes = 0; /* First event is return to BCE */ if events_by_time then do; if delta_time = 0 then earliest_time = 0; else earliest_time = dump.mctime - delta_time; end; n_events = 0; call add_an_event (bin (dump.mctime, 71), addr (dump.scu (0)), print_dump_mc, "RTB Machine Conditions", "0"b, "0"b); /* Go through segments dumped, building events in event array */ do proc_no = 0 to hbound (fdump_process_table.array, 1); call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, proc_no); stack_segs (*) = -1; /* do stack_inx = 0 to hbound (stack_segs, 1); stack_segs (stack_inx) = -1; end;*/ interesting_segs (MC_TRACE_BUF).process_this_seg = "0"b; /* mc tracing is per-process */ fp_table_ptr = addr (fdump_process_table.array (proc_no)); do dump_seginx = fp_table.first_seg to fp_table.last_seg; dump_segno = bin (dump.segs (dump_seginx).segno, 18); if dump_segno <= slt.last_sup_seg /* only hardcore segs are interesting */ | interesting_segs (MC_TRACE_BUF).process_this_seg /* unless tracing machine conditions */ then do; seg_found = "0"b; seginx = 1; do while (^seg_found & seginx <= N_INTERESTING_SEGS); if dump_segno = interesting_segs.segno (seginx) then seg_found = "1"b; else seginx = seginx + 1; end; if seg_found & interesting_segs (seginx).process_this_seg then do; call interesting_segs (seginx).handler (interesting_segs (seginx).process_this_seg); if code ^= 0 then do; COPY_ERR: call amu_$error_for_caller ((null ()), code, MYNAME, "seg index ^d", dump_seginx); call cleanit; return; end; end; end; stack_found = "0"b; do stack_inx = 0 repeat stack_inx + 1 while (^stack_found & stack_inx <= hbound (stack_segs, 1)); if stack_segs (stack_inx) = dump_segno then do; call process_user_stack (stack_inx, dump_segno); if code ^= 0 then goto COPY_ERR; stack_found = "1"b; end; end; end; end; /* Now extract messages from the syserr log which are within the interval of interest; we must process each of the syserr log segments in turn. */ call process_syserr_log (earliest_recorded_time, tsegp, "syserr_log_laurel"); call process_syserr_log (earliest_recorded_time, tsegp, "syserr_log_hardy"); %page; /* Sort event array by time stamp (tag sort) */ sortp = allocate_temp_seg (); do sortinx = 1 to n_events; sort_index (sortinx) = sortinx; end; do sortinx = 1 to n_events - 1; do sortinx1 = sortinx + 1 to n_events; if events (sort_index (sortinx1)).time_stamp > events (sort_index (sortinx)).time_stamp then do; sortinxt = sort_index (sortinx1); /* swap pointers */ sort_index (sortinx1) = sort_index (sortinx); sort_index (sortinx) = sortinxt; end; else if events (sort_index (sortinx1)).time_stamp = events (sort_index (sortinx)).time_stamp then do; if events (sort_index (sortinx1)).delete_on_duplicate_time then events (sort_index (sortinx1)).deleted = "1"b; if events (sort_index (sortinx)).delete_on_duplicate_time then events (sort_index (sortinx)).deleted = "1"b; end; end; end; %page; /* Print the sorted events by calling the print routine for each, passing the decoded time value */ first_print = "1"b; last_date_time = " "; last_sec = -1; events_printed = 1; if events_by_time then max_events = n_events; else max_events = min (n_events, num_events); do event_inx = 1 to n_events while (events_printed <= max_events); if ^events (sort_index (event_inx)).deleted then do; events_printed = events_printed + 1; call decode_clock_value_$date_time (events (sort_index (event_inx)).time_stamp, mon, dom, yr, hr, minute, sec, micsec, dow, "", code); if code = 0 then do; MON = mon; DOM = dom; YR = mod (yr, 100); HR = hr; MIN = minute; SEC = sec; MICSEC = micsec; cur_date_time = MON || "/" || DOM || "/" || YR || " " || HR || ":" || MIN; if cur_date_time ^= last_date_time then call ioa_ ("Events from ^a:^a.^a", cur_date_time, SEC, MICSEC); if first_print then do; call ioa_ ("^4xTime^2xCPU Proc Event^27xCircumstances^/"); first_print = "0"b; end; last_date_time = cur_date_time; if last_sec = sec then call ioa_$rsnnl (" .^6a ", temp_time, tsl, MICSEC); else call ioa_$rsnnl ("^2a.^6a ", temp_time, tsl, SEC, MICSEC); last_sec = sec; if match_info_ptr = null () then call ioa_$nnl (temp_time); /* Find FDUMP Process Number if necessary */ process_number = events (sort_index (event_inx)).process_number; if events (sort_index (event_inx)).apte_offset ^= "0"b then do; apt_proc_found = "0"b; apt_inx = 1; do while (^apt_proc_found & apt_inx <= apt_array.n_aptes); if events (sort_index (event_inx)).apte_offset = apt_array.apt_desc (apt_inx).offset then do; apt_proc_found = "1"b; process_number = apt_array.apt_desc (apt_inx).procn; end; else apt_inx = apt_inx + 1; end; end; call events (sort_index (event_inx)) . event_display (events (sort_index (event_inx)).added_info, events (sort_index (event_inx)).event_struct_ptr, process_number); end; end; end; GLOBAL_RETURN: call cleanit; RETURN: return; %page; /* Internal procedure to add an event to the structure if its time is within the range of interest */ add_an_event: proc (etime, eptr, eroutine, eadded_info, delete_duplicate, apte_offset); dcl etime fixed bin (71); /* time of event */ dcl eptr ptr; /* pointer to event structure */ dcl eroutine entry (char (*), ptr, fixed bin) variable; /* routine to print event */ dcl eadded_info char (*); /* clear-text info of interest */ dcl delete_duplicate bit (1) aligned; /* ON => delete this event if duplicate times */ dcl apte_offset bit (18); /* APTE offset or "0"b */ if events_by_time then if etime < earliest_time then return; n_events = n_events + 1; events (n_events).time_stamp = etime; events (n_events).event_struct_ptr = eptr; events (n_events).event_display = eroutine; events (n_events).added_info = eadded_info; events (n_events).process_number = proc_no; events (n_events).apte_offset = apte_offset; events (n_events).deleted = "0"b; events (n_events).delete_on_duplicate_time = delete_duplicate; if events_by_time then if etime < earliest_recorded_time & etime ^= 0 then earliest_recorded_time = etime; end add_an_event; %page; /* Internal Procedure to allocate an additional temporary segment, and return a pointer to same */ allocate_temp_seg: proc returns (ptr); call ssu_$get_temp_segment (sci_ptr, MYNAME, temp_segp (n_temp_segs + 1)); n_temp_segs = n_temp_segs + 1; return (temp_segp (n_temp_segs)); end allocate_temp_seg; %page; /* Internal Procedure for Cleanup */ cleanit: proc; dcl i fixed bin; if temp_seg_data_p ^= null () then do; do i = 0 to n_temp_segs; if temp_segp (i) ^= null then call ssu_$release_temp_segment (sci_ptr, temp_segp (i)); end; call ssu_$release_temp_segment (sci_ptr, temp_seg_data_p); temp_seg_data_p = null (); end; if sortp ^= null then call ssu_$release_temp_segment (sci_ptr, sortp); if tsegp ^= null then call ssu_$release_temp_segment (sci_ptr, tsegp); if match_info_ptr ^= null then call match_strings_$free (match_info_ptr); end cleanit; %page; /* Internal Procedure to copy the PVT to a temporary segment. This is necessary to print some of the interesting stuff about disk queues */ copy_pvt: proc (process_it); dcl process_it bit (1) aligned; process_it = "1"b; /* Only copy PVT once */ if ^long_report then return; pvtp = allocate_temp_seg (); words_copied = sys_info$max_seg_size; call get_data (pvtp,dump_segno, 0, words_copied, code); end copy_pvt; %page; /* Internal Procedure to copy a part of a segment to a temporary segment. Additional temporary segments are allocated as necessary, and a pointer to the copy is returned */ copy_to_temporary: proc (dptr, dlength) returns (ptr); dcl dptr ptr; /* pointer to part of segment to copy */ dcl dlength fixed bin (18); /* number of words to copy */ dcl tlength fixed bin (18); dcl tptr ptr; dcl based_move (tlength) fixed bin (35) aligned based; tlength = divide (dlength + 7, 8, 18) * 8; /* Make modulo 8 */ if temp_alloc_p = null () /* first time here */ then temp_alloc_p = allocate_temp_seg (); else if bin (rel (temp_alloc_p), 18) + tlength > sys_info$max_seg_size then temp_alloc_p = allocate_temp_seg (); tptr = temp_alloc_p; temp_alloc_p = addrel (temp_alloc_p, tlength); tptr -> based_move = dptr -> based_move; return (tptr); end copy_to_temporary; %page; /* Internal procedure to get data from a dump */ get_data: proc (data_ptr, seg, word, number, ecode); dcl ecode fixed bin (35); dcl data_ptr ptr; dcl index_changed bit (1) init ("0"b); dcl seg fixed bin; dcl (word, number) fixed bin (18); if ^amu_$return_val_per_process (amu_info_ptr, seg) then do; index_changed = "1"b; call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, lbound (fdump_process_table.array, 1)); end; call amu_$do_translation (amu_info_ptr, seg, data_ptr, word, number, ecode); if index_changed = "1"b then do; call amu_$fdump_mpt_revert_idx (amu_info_ptr); index_changed = "0"b; end; end get_data; %page; get_trans: proc (segno) returns (ptr); dcl segno fixed bin; dcl t_ptr ptr; dcl amu_$translate_get entry (ptr, fixed bin, ptr, fixed bin(35)); dcl amu_$fdump_translate_get_translation entry (ptr, ptr, ptr, fixed bin(35)); call amu_$translate_get (amu_info_ptr,segno,t_ptr,code); if t_ptr ^= null () then return (t_ptr); else do; t_ptr = addr(translation_space); call amu_$fdump_translate_get_translation (amu_info_ptr,baseptr(segno),t_ptr,code); if code ^= 0 then return (null ()); else return (t_ptr); end; end get_trans; /* Internal Procedure to print apte */ print_apte: proc (added_info, structp, process_n); dcl added_info char (*); dcl structp ptr; dcl process_n fixed bin; dcl state_name char (10); dcl process_na pic "zz9"; dcl real_apte_offset fixed bin (18); dcl STATE_NAMES (0:6) char (10) int static options (constant) init ("Empty", "Running", "Ready", "Waiting", "Blocked", "Stopped", "ptlocking"); dcl WAITING fixed bin init (3) int static options (constant); aptep = structp; if bin (apte.state, 18) > hbound (STATE_NAMES, 1) then state_name = "Invalid"; else state_name = STATE_NAMES (bin (apte.state, 18)); process_na = process_n; real_apte_offset = fixed (rel(aptep),18) - fixed (rel(hardcore_cur.tc_datap),18); /* Print the interesting information from the apte */ call ioa_$rsnnl ("^1a^2x^3a APTE at ^6o changed to ^a^[ for ^w^;^s^]", temp_string, tsl, substr (CPU_TAG, bin (apte.pr_tag, 3) + 1, 1), process_na, real_apte_offset, state_name, (bin (apte.state, 18) = WAITING), apte.wait_event); if match_info_ptr = null () then call ioa_ ("^a", temp_string); else call mh_or_ex (""b); end print_apte; %page; /* Internal Procedure to print Connect to Device information */ print_device_data: proc (added_info, structp, process_n); dcl added_info char (*); dcl structp ptr; dcl process_n fixed bin; /* not meaningful for this data */ dcl 1 iom_dev_data aligned like per_device based (structp); call ioa_$rsnnl ("^8xConnect to ^1a ^2d", temp_string, tsl, substr (IOM_TAG, iom_dev_data.iom, 1), iom_dev_data.channel); if match_info_ptr = null () then call ioa_ ("^a", temp_string); else call mh_or_ex (""b); end print_device_data; %page; /* Internam Procedure to print Disk Queue information */ print_disk_queue: proc (info, dq_data_ptr, process_char); dcl info char (*); dcl dq_data_ptr ptr; dcl process_char char (*); dcl type_io fixed bin; dcl dev_num char (2); dcl diskadd fixed bin; dcl fsx fixed bin; dcl p99 pic "99"; dcl sect_sw bit (1); dcl subsys_name char (4); dcl DISK_IO_TYPE (0:6) char (7) static options(constant) init ("Page RD","Page WT","Vtoc RD", "Vtoc WT","Test","Boot RD","Boot WT"); diskq_datap = dq_data_ptr; type_io = diskq_data.io_type; if pvtp = null () then do; /* PVT not in dump - not to worry */ subsys_name = "dskX"; dev_num = "NN"; sect_sw = "1"b; /* Can't translate to record */ diskadd = diskq_data.sector; end; else do; pvt_arrayp = addr (pvt.array); pvtep = addr (pvt_array (diskq_data.pvtx)); if index (pvte.devname, "dsk") = 0 then subsys_name = "????"; else subsys_name = pvte.devname; if pvte.logical_area_number < -99 | pvte.logical_area_number > 99 then pvte.logical_area_number = 0; dev_num = convert (p99, pvte.logical_area_number); sect_sw = sector_map (type_io); if sect_sw then diskadd = diskq_data.sector; else do; fsx = pvte.device_type; diskadd = diskq_data.cylinder * rec_per_cyl (fsx) + divide (diskq_data.sector - diskq_data.cylinder * sect_per_cyl (fsx), sect_per_rec (fsx), 17); end; end; call ioa_$rsnnl ("^8xDisk Queue: ^a_^a ^a ^[Sec^;Rec^] ^8o Mem ^8o^[ (I)^;^]", temp_string, tsl, subsys_name, dev_num, DISK_IO_TYPE(type_io), sect_sw, diskadd, diskq_data.coreadd, diskq_data.used); if match_info_ptr = null () then call ioa_ ("^a", temp_string); else call mh_or_ex (""b); end print_disk_queue; %page; /* Internal Procedure to print BCE machine conditions */ print_dump_mc: proc (added_info, structp, process_n); dcl added_info char (*); dcl structp ptr; dcl process_n fixed bin; /* process number meaningless here */ call print_scu_data (structp, added_info, " "); end print_dump_mc; %page; /* Internal Procedure to print machine conditions */ print_mc: proc (added_info, structp, process_n); dcl added_info char (*); dcl structp ptr; dcl process_n fixed bin; dcl process_na pic "zz9"; dcl process_num char (3); process_na = process_n; process_num = process_na; call print_scu_data (structp, added_info, process_num); end print_mc; %page; /* Internal procedure to extract parameters from syserr_log event for printing */ print_syserr_log: proc (added_info, structp, process_n); dcl added_info char (*); dcl structp ptr; dcl process_n fixed bin; /* Really, this should be using format_log_message_ and doing things right, but this should do for the moment. The conversion should be finished, however, when and if syserr_data is converted to use new format messages. */ log_message_ptr = structp; call print_syserr_message (log_message.sequence, (log_message.severity), "syserr_log", length (log_message.text), addr (log_message.text)); return; end print_syserr_log; %page; /* Internal procedure to print a syserr message */ print_syserr_message: proc (sequence, severity, log_name, textl, textp); dcl sequence fixed bin (35); /* syserr sequence number */ dcl severity fixed bin; /* syserr severity code */ dcl log_name char (*); /* name of log where the message came from */ dcl textl fixed bin (21); /* length of message is chars */ dcl textp ptr; /* pointer to text of message */ dcl linel fixed bin (21); dcl textl_done fixed bin (21); dcl textl_total fixed bin (21); dcl trim_eol fixed bin (21); dcl 1 message based (textp), 2 pad char (textl_done), 2 this_line char (linel), 2 rest char (textl_total - linel - textl_done); dcl LINE_MAX_LENGTH fixed bin init (59) int static options (constant); dcl TEXT_MAX_LENGTH fixed bin init (200) int static options (constant); call ioa_ ("^8xSyserr #^d (^a), severity ^d", sequence, log_name, severity); textl_total = min (TEXT_MAX_LENGTH, textl); textl_done = 0; linel = textl_total; if linel <= 0 then return; do while (linel > 0); if linel > LINE_MAX_LENGTH then do; linel = LINE_MAX_LENGTH; trim_eol = index (substr (reverse (message.this_line), 1, 20), " "); linel = linel - trim_eol; end; call ioa_ ("^21x^a", message.this_line); textl_done = textl_done + linel; linel = textl_total - textl_done; end; end print_syserr_message; %page; /* Internal procedure to prepare a syserr message from the wired log for printing */ print_wired_syserr: proc (added_info, structp, process_n); dcl added_info char (*); dcl structp ptr; dcl process_n fixed bin; dcl sequence fixed bin (35); dcl severity fixed bin; dcl textl fixed bin (21); dcl textp ptr; wmess_ptr = structp; sequence = wmess.seq_num; severity = wmess.code; textl = wmess.text_len; textp = addr (wmess.text); call print_syserr_message (sequence, severity, "syserr_data", textl, textp); end print_wired_syserr; %page; /* Internal procedure to print SCU data from machine conditions */ print_scu_data: proc (scu_data_ptr, info, process_char); dcl scu_data_ptr ptr; /* pointer to scu data in machine conditions */ dcl info char (*); /* additional information to print */ dcl process_char char (*); /* process number printably */ dcl cpu_alph char (1); dcl fault_no fixed bin; dcl fault_sub_type bit (36); dcl hardware_interrupt_level fixed bin; dcl hardware_interrupt_no pic "99"; dcl interrupt_level pic "9"; dcl interrupt_no fixed bin; dcl iom_number char (1); dcl line1 char (80) varying; dcl ptsr bit (1); dcl exp_seg_name char (256) varying; dcl seg_valid bit (1); dcl sub_type_inx fixed bin; dcl SR_IOA_STRING char (50) int static options (constant) init ("^21x^3a ^o|^o^[, ring ^1o^;^s^[ (^a)^;^s^]^]"); dcl FAULT_TYPES (0:31) char (4) int static options (constant) init ("SDF", "STR", "MME", "FT1", "TRO", "CMD", "DRL", "LUF", "CON", "PAR", "IPR", "ONC", "SUF", "OFL", "DIV", "EXF", "DF0", "DF1", "DF2", "DF3", "ACV", "MME2", "MME3", "MME4", "FT2", "FT3", "INV", "INV", "INV", "INV", "INV", "TRB"); dcl FAULT_TSR_VALID bit (32) init ("01110111011101101111111111000001"b) int static options (constant); dcl FAULT_MASK_INDEX (0:31) fixed bin int static options (constant) init (0, 1, (7) 0, 2, 3, 4, (8) 0, 5, (11) 0); dcl FAULT_MASKS (5) bit (21) aligned int static options (constant) init ("4140000"b3, /* Store */ "0000030"b3, /* Parity */ "3600000"b3, /* Illegal Procedure */ "0000006"b3, /* Operation Not Complete */ "7777740"b3); /* Access Violation */ dcl FAULT_SUB_TYPES (5, 21) char (5) int static options (constant) init ("ISN", (4) (3)" ", "NEA", "OOB", (14) (3)" ", /* Store */ (16) (3)" ", "PARU", "PARL", (3) (3)" ", /* Parity */ " ", "IOC", "IA+IM", "ISP", "IPR", (16) (3)" ", /* Illegal Procedure */ (18) (3)" ", "ONC1", "ONC2", " ", /* Operation Not Complete */ "IRO", "OEB", "E-OFF", "ORB", "R-OFF", "OWB", /* Access Violation */ "W-OFF", "NO GA", "OCB", "OCALL", "BOC", "INRET", /* Access Violation */ "CRT", "RALR", "AM-ER", "OOSB", (5) (1)" "); /* Access Violation */ exp_seg_name = ""; scup = scu_data_ptr; cpu_alph = substr (CPU_TAG, bin (scu.cpu_no, 3) + 1, 1); if scu.fi_flag then do; /* Fault */ fault_no = bin (scu.fi_num, 17); line1 = "Fault: " || FAULT_TYPES (fault_no); ptsr = substr (FAULT_TSR_VALID, fault_no + 1, 1); if FAULT_MASK_INDEX (fault_no) ^= 0 then do; /* subtype of fault */ fault_sub_type = unspec (scu.fd) & FAULT_MASKS (FAULT_MASK_INDEX (fault_no)); sub_type_inx = index (fault_sub_type, "1"b); if sub_type_inx ^= 0 then line1 = line1 || " (" || rtrim (FAULT_SUB_TYPES (FAULT_MASK_INDEX (fault_no), sub_type_inx)) || ")"; end; end; else do; /* Interrupt */ ptsr = "0"b; interrupt_no = bin (scu.fi_num, 5); hardware_interrupt_level = divide (interrupt_no, 4, 17); if hardware_interrupt_level = 0 | hardware_interrupt_level = 6 then do; hardware_interrupt_no = interrupt_no; line1 = "Interrupt: Number " || hardware_interrupt_no; end; else do; interrupt_level = hardware_interrupt_level + mod (hardware_interrupt_level + 1, 2); iom_number = substr (IOM_TAG, mod (interrupt_no, 4) + 1, 1); line1 = "Interrupt: IOM " || iom_number || ", Level " || interrupt_level; end; end; call ioa_$rsnnl ("^1a^2x^3a^2x^32a^a", temp_string, tsl, cpu_alph, process_char, line1, info); if match_info_ptr = null () then call ioa_ ("^a", temp_string); else call mh_or_ex (""b); if long_report then do; seg_valid = "0"b; exp_seg_name = amu_$get_name (amu_info_ptr, pointer (baseptr (bin (scu.ppr.psr, 15)), bin (scu.ilc, 18))); if index (exp_seg_name, "CANNOT") = 0 then seg_valid = "1"b; call ioa_$rsnnl (SR_IOA_STRING, temp_string, tsl, "by ", bin (scu.ppr.psr, 15), bin (scu.ilc, 18), scu.ppr.prr, scu.ppr.prr, seg_valid, exp_seg_name); if match_info_ptr = null () then call ioa_ ("^a", temp_string); else call mh_or_ex ("1"b); if ptsr then do; /* print TSR/CA if valid */ seg_valid = "0"b; exp_seg_name = amu_$get_name (amu_info_ptr, pointer (baseptr (bin (scu.tpr.tsr, 15)), bin (scu.ca, 18))); if index (exp_seg_name, "CANNOT") = 0 then seg_valid = "1"b; call ioa_$rsnnl (SR_IOA_STRING, temp_string, tsl, "ref", bin (scu.tpr.tsr, 15), bin (scu.ca, 18), scu.tpr.trr, scu.tpr.trr, seg_valid, exp_seg_name); if match_info_ptr = null () then call ioa_ ("^a", temp_string); else call mh_or_ex ("1"b); end; end; end print_scu_data; %page; /* Internal Procedure to scan disk_seg and extract all queue entries */ process_disk_queue: proc (process_it); dcl disk_seg_ptr ptr; dcl process_it bit (1) aligned; dcl qx fixed bin; dcl queue_time fixed bin (71); dcl 1 diskq_temp aligned like diskq_data; if ^new_disk_dim_sw then return; process_it = "0"b; if ^long_report then return; words_copied = sys_info$max_seg_size; call get_data (tsegp, dump_segno, 0, words_copied, code); if code ^= 0 then return; disk_seg_ptr = tsegp; disksp = disk_seg_ptr; if disk_data.array(1).mbz ^= "0"b then do; new_disk_dim_sw = "0"b; return; end; do qx = 1 to disk_data.free_q_size; qp = addr (disk_data.free_q_entries (qx)); if quentry.time ^= 0 then if (^events_by_time | (events_by_time & quentry.time >= earliest_time)) then do; diskq_temp.pvtx = quentry.pvtx; diskq_temp.io_type = quentry.type; diskq_temp.coreadd = bin (quentry.coreadd, 25); diskq_temp.sector = bin (quentry.sector, 21); diskq_temp.cylinder = quentry.cylinder; diskq_temp.used = quentry.used; queue_time = quentry.time; call add_an_event (queue_time, copy_to_temporary (addr (diskq_temp), size (diskq_temp)), print_disk_queue, "Disk Queue", "0"b, "0"b); end; end; end process_disk_queue; %page; /* Internal Procedure to scan a per-process machine condition trace buffer for machine conditions */ process_mc_trace_buf: proc (process_it); dcl mctbp ptr; dcl process_it bit (1) aligned; dcl len fixed bin (21); dcl mcptr ptr; dcl mcx fixed bin; dcl mc_seg_offset char (30); dcl mct_scu_ptr ptr; words_copied = sys_info$max_seg_size; call get_data (tsegp, dump_segno, 0, words_copied, code); if code ^= 0 then return; mctbp = tsegp; process_it = "0"b; bp = mctbp; do mcx = 1 to mc_trace_buf.mc_cnt; mcptr = addr (mc_trace_buf.mach_cond (mcx)); if addr (mcptr -> mc.scu (0)) -> scu.ppr.psr ^= "0"b then do; call ioa_$rsnnl ("mc_trace_buf (^o|^o)", mc_seg_offset, len, dump_segno, bin (rel (mcptr))); mct_scu_ptr = copy_to_temporary (addr(mcptr -> mc.scu), size (scu)); call add_an_event (bin (mcptr -> mc.fault_time, 54), mct_scu_ptr, print_mc, mc_seg_offset, "1"b, "0"b); end; end; end process_mc_trace_buf; %page; /* Internal procedure to setup call to scan inzr_stk0 */ process_inzr_stk0: proc (process_it); dcl process_it bit (1) aligned; /* flag to process segment again */ dcl code fixed bin (35); dcl segp ptr; process_it = "0"b; /* only come here once */ call amu_$slt_search_seg_ptr (hardcore_cur.sltp, hardcore_cur.sltntp, "inzr_stk0", segp, code); if code ^= 0 then return; call walk_stack (bin (baseno (segp)), "inzr_stk0"); end process_inzr_stk0; %page; /* Internal Procedure to scan iom_data for events of interest */ process_iom_data: proc (process_it); dcl iom_data_p ptr; dcl process_it bit (1) aligned; dcl dev_no fixed bin; dcl per_device_p ptr; words_copied = sys_info$max_seg_size; call get_data (tsegp, dump_segno, 0, words_copied, code); if code ^= 0 then return; iom_data_p = tsegp; process_it = "0"b; /* only come here once */ iom_data_ptr = iom_data_p; if iom_data.n_devices > 0 then do dev_no = 1 to iom_data.n_devices; per_device_p = copy_to_temporary (addr (iom_data.per_device (dev_no)), size (per_device)); call add_an_event (iom_data.per_device (dev_no).connect_time, per_device_p, print_device_data, "per_device", "0"b, "0"b); end; end process_iom_data; %page; /* Internal Procedure to scan the PDS for events of interest */ process_pds: proc (process_it); dcl pdsp ptr; /* pointer to copied-out pds */ dcl process_it bit (1) aligned; /* flag to process this seg again */ dcl aptp ptr; dcl bpp ptr; dcl mcptr ptr; dcl mcp_scu_ptr ptr; dcl names_inx fixed bin; dcl pds_stacks_inx fixed bin; dcl pds_stacks_ptr ptr; dcl pds_names (3) char (32) int static options (constant) init ("page_fault_data", "fim_data", "signal_data"); dcl based_flag fixed bin (35) based; dcl based_ptr ptr aligned based; dcl based_ptr_packed ptr unaligned based; dcl pds_stacks (0:7) ptr aligned based (pds_stacks_ptr); words_copied = sys_info$max_seg_size; call get_data (tsegp, dump_segno, 0, words_copied, code); if code ^= 0 then return; pdsp = tsegp; aptp = ptr (pdsp, amu_$definition_offset (amu_info_ptr, "pds", "apt_ptr", code)); if code ^= 0 then do; call amu_$error_for_caller ((null ()), code, MYNAME, "Cannot find pds$apt_ptr in dump."); end; if aptp = null () then return; if rel (aptp -> based_ptr) = "0"b then return; apt_array.n_aptes = apt_array.n_aptes + 1; apt_array.apt_desc (n_aptes).offset = rel (aptp -> based_ptr); apt_array.apt_desc (n_aptes).procn = proc_no; do names_inx = 1 to hbound (pds_names, 1); call validate_mc (pdsp, "pds", pds_names (names_inx),mcptr,mcp_scu_ptr); if mcptr ^= null () then do; /* machine condtions exist */ call add_an_event (bin (mcptr -> mc.fault_time, 54), mcp_scu_ptr, print_mc, "pds$" || rtrim (pds_names (names_inx)), "0"b, "0"b); end; end; /* Extract stack segment numbers from the pds */ pds_stacks_ptr = ptr (pdsp, amu_$definition_offset (amu_info_ptr, "pds", "stacks", code)); if code ^= 0 then do; call amu_$error_for_caller ((null ()), code, MYNAME, "Cannot find pds$stacks in dump."); end; if fixed(rel(pds_stacks_ptr),18) >= words_copied then return; if pds_stacks_ptr = null () then return; do pds_stacks_inx = 0 to hbound (pds_stacks, 1); if pds_stacks (pds_stacks_inx) ^= null () then stack_segs (pds_stacks_inx) = bin (baseno (pds_stacks (pds_stacks_inx)), 17); else stack_segs (pds_stacks_inx) = -1; end; /* Check whether this process is tracing machine conditions */ bpp = ptr (pdsp, amu_$definition_offset (amu_info_ptr, "pds", "mc_trace_sw", code)); if code ^= 0 then do; call amu_$error_for_caller ((null ()), code, MYNAME, "Cannot find pds$mc_trace_sw in dump."); end; if bpp = null () then return; if bpp -> based_flag = 0 then return; bpp = ptr (pdsp, amu_$definition_offset (amu_info_ptr, "pds", "mc_trace_buf", code)); if code ^= 0 then do; call amu_$error_for_caller ((null ()), code, MYNAME, "Cannot find pds$mc_trace_buf in dump."); end; if bpp = null () then return; interesting_segs (MC_TRACE_BUF).process_this_seg = "1"b; interesting_segs (MC_TRACE_BUF).segno = bin (baseno (bpp -> based_ptr_packed), 18); end process_pds; %page; /* Internal procedure to scan prds for interesting events */ process_prds: proc (process_it); dcl prdsp ptr; /* pointer to copied-out prds */ dcl process_it bit (1) aligned; /* flag to process prds again */ dcl mcptr ptr; dcl mcp_scu_ptr ptr; dcl names_inx fixed bin; dcl processor_tag fixed bin; dcl prtag_based fixed bin aligned based; dcl prtagp ptr; dcl apte_offset bit (18); dcl bpp ptr; dcl based_ptr ptr based; dcl prds_names (3) char (32) int static options (constant) init ("sys_trouble_data", "interrupt_data", "fim_data"); words_copied = sys_info$max_seg_size; call get_data (tsegp, dump_segno, 0, words_copied, code); if code ^= 0 then return; prdsp = tsegp; prtagp = ptr (prdsp, amu_$definition_offset (amu_info_ptr, "prds", "processor_tag", code)); if code ^= 0 then do; call amu_$error_for_caller ((null ()), code, MYNAME, "Cannot find prds$processor_tag in dump."); end; if prtagp = null () then return; processor_tag = prtagp -> prtag_based; if processor_tag > 7 then goto define_bpp; if ^substr (prds_processor, processor_tag + 1, 1) /* seen this prds before */ then return; substr (prds_processor, processor_tag + 1, 1) = "0"b; if prds_processor = "0"b then process_it = "0"b; /* last prds on system */ define_bpp: bpp = ptr (prdsp, amu_$definition_offset (amu_info_ptr, "prds", "apt_ptr", code)); if code ^= 0 then do; call amu_$error_for_caller ((null ()), code, MYNAME, "Cannot find prds$apt_ptr in dump."); end; if bpp = null () then apte_offset = "0"b; else apte_offset = rel (bpp -> based_ptr); do names_inx = 1 to hbound (prds_names, 1); call validate_mc (prdsp, "prds", prds_names (names_inx),mcptr,mcp_scu_ptr); if mcptr ^= null () then do; call add_an_event (bin (mcptr -> mc.fault_time, 54), mcp_scu_ptr, print_mc, "prds$" || rtrim (prds_names (names_inx)), (prds_names (names_inx) ^= "sys_trouble_data"), apte_offset); end; end; end process_prds; %page; /* Internal procedure to extract messages from the wired syserr buffer */ process_syserr_data: proc (process_it); dcl syserr_data_ptr ptr; /* pointer to copy of syserr_data */ dcl process_it bit (1) aligned; /* flag to process this seg again */ dcl wlog_inx fixed bin; dcl wp ptr; dcl wtime fixed bin (71); words_copied = sys_info$max_seg_size; call get_data (tsegp, dump_segno, 0, words_copied, code); if code ^= 0 then return; syserr_data_ptr = tsegp; process_it = "0"b; /* only come here once */ wlog_ptr = ptr (syserr_data_ptr, amu_$definition_offset (amu_info_ptr, "syserr_data", "wired_log_area", code)); if code ^= 0 then do; call amu_$error_for_caller ((null ()), code, MYNAME, "Cannot find syserr_data$wired_log_area in dump."); end; if wlog_ptr = null () then return; wmess_ptr = addr (wlog.buffer); if wlog.head.count < 1 then return; /* no messages in buffer */ do wlog_inx = 1 to wlog.head.count; wp = copy_to_temporary (wmess_ptr, divide (length (unspec (wmess)), 36, 18)); wtime = wmess.time; call add_an_event (wtime, wp, print_wired_syserr, "syserr_data", "0"b, "0"b); wmess_ptr = addrel (wmess_ptr, divide (length (unspec (wmess)), 36, 18)); end; end process_syserr_data; %page; /* Internal procedure to scan syserr log for messages within interval of interest */ process_syserr_log: proc (low_time, temp_ptr, log_name); dcl low_time fixed bin (71); /* earliest time of interest */ dcl temp_ptr ptr; /* temporary segment we can use */ dcl log_name char (32); /* name of syserr log segment (Laurel or Hardy) */ dcl code fixed bin (35); dcl slog_p ptr; dcl slog_no fixed bin; dcl last_offset fixed bin (18); dcl first_time bit (1) aligned; dcl temp_message_ptr pointer; dcl log_segment_$last_message_info entry (ptr, fixed bin(35), fixed bin(18), fixed bin(35)); dcl log_position_$next_message entry (ptr, ptr, bit(1) aligned); /* Find syserr_log in the dump */ call amu_$slt_search_seg_ptr (hardcore_cur.sltp, hardcore_cur.sltntp, log_name, slog_p, code); if code ^= 0 then do; SLOG_ERROR: call amu_$error_for_caller ((null ()), code, MYNAME, "Error encountered processing ^a", log_name); return; end; slog_no = bin (baseno (slog_p), 18); /* Copy the log_segment header */ range = size (log_segment_header); call get_data (temp_ptr, slog_no, 0, range, code); if code ^= 0 | range = 0 then goto SLOG_ERROR; /* Find out how much was actually used in this segment, and copy out as much of the segment as that accounts for */ call log_segment_$last_message_info (temp_ptr, (0), last_offset, code); if (code ^= 0) then goto SLOG_ERROR; range = last_offset; call get_data (temp_ptr, slog_no, 0, range, code); if code ^= 0 | range = 0 then goto SLOG_ERROR; /* Romp through, picking out events within the interval of interest--i.e., times less than earliest one found elsewhere */ log_message_ptr = null (); log_segment_ptr = temp_ptr; first_time = "1"b; do while (first_time | (log_message_ptr ^= null ())); first_time = "0"b; call log_position_$next_message (log_segment_ptr, log_message_ptr, ("0"b)); /* If there was another message available, see if it's in the desired time range, and add it to the list. NOTE: This used to check to see whether the message came after the time of the dump, but that seemed like a pretty silly thing to be checking, since if there ARE any "later" messages, we certainly would want to see them. */ if (log_message_ptr ^= null ()) then if (log_message.time >= low_time) then do; temp_message_ptr = copy_to_temporary (log_message_ptr, currentsize (log_message)); call add_an_event ((log_message.time), temp_message_ptr, print_syserr_log, "syserr_log", "0"b, "0"b); end; /* of case of interesting message */ end; /* of loop through log segment */ return; end process_syserr_log; %page; /* Internal procedure to scan tc_data for interesting events */ process_tc_data: proc (process_it); dcl process_it bit (1) aligned; dcl aptx fixed bin; dcl bp ptr; dcl num_aptes fixed bin; dcl size_of_apte fixed bin; dcl tp ptr; dcl tp_base fixed bin (35); dcl real_apte bit (18); dcl fixed_apte fixed bin (35); dcl EMPTY fixed bin init (0) int static options (constant); dcl based_fixed fixed bin (35) aligned based; process_it = "0"b; /* only process tc_data once */ /* amu_$hardcore_info_fdump claims that tc_data is translated contiguous */ tp = hardcore_cur.tc_datap; tp_base = fixed (rel (tp),35); bp = addrel (tp, amu_$definition_offset (amu_info_ptr, "tc_data", "apt_size", code)); if code ^= 0 then do; call amu_$error_for_caller ((null ()), code, MYNAME, "Cannot find tc_data$apt_size in dump."); end; if bp = null () then return; num_aptes = bp -> based_fixed; if num_aptes <= 0 then return; bp = addrel (tp, amu_$definition_offset (amu_info_ptr, "tc_data", "apt_entry_size", code)); if code ^= 0 then do; call amu_$error_for_caller ((null ()), code, MYNAME, "Cannot find tc_data$apt_entry_size in dump."); end; if bp = null () then return; size_of_apte = bp -> based_fixed; if size_of_apte <= 0 then return; aptep = addrel (tp, amu_$definition_offset (amu_info_ptr, "tc_data", "apt", code)); if code ^= 0 then do; call amu_$error_for_caller ((null ()), code, MYNAME, "Cannot find tc_data$apt in dump."); end; if aptep = null () then return; do aptx = 1 to num_aptes; if bin (apte.state, 18) ^= EMPTY & apte.state_change_time ^= 0 then do; fixed_apte = fixed (rel(aptep),35) - tp_base; real_apte = substr(unspec(fixed_apte),19,18); call add_an_event (apte.state_change_time, aptep, print_apte, "apte", "0"b, real_apte); end; aptep = addrel (aptep, size_of_apte); end; end process_tc_data; %page; /* Internal procedure to set up a stack for scanning */ process_user_stack: proc (ring_no, stack_seg_no); dcl ring_no fixed bin; /* ring number of stack in process */ dcl stack_seg_no fixed bin; /* segment number of stack in process */ dcl ring_num pic "9"; ring_num = ring_no; call walk_stack (stack_seg_no, "stack_" || ring_num); end process_user_stack; %page; /* Internal procedure to get interesting data from scs */ setup_from_scs: proc (process_it); dcl scs_ptr ptr; /* pointer to copy of scs */ dcl process_it bit (1) aligned; /* flag to process segment again */ dcl proc_number fixed bin; dcl proc_exists_mask bit (8); dcl scs_proc_data_ptr ptr; dcl 1 pdata (0:7) aligned like scs$processor_data based (scs_proc_data_ptr); words_copied = sys_info$max_seg_size; call get_data (tsegp, dump_segno, 0, words_copied, code); if code ^= 0 then return; scs_ptr = tsegp; process_it = "0"b; /* process scs but once */ proc_exists_mask = "0"b; scs_proc_data_ptr = ptr (scs_ptr, amu_$definition_offset (amu_info_ptr, "scs", "processor_data", code)); if code ^= 0 then do; call amu_$error_for_caller ((null ()), code, MYNAME, "Cannot find scs$processor_data in dump."); end; if scs_proc_data_ptr = null () then return; do proc_number = 0 to hbound (pdata, 1); /* find all cpus which might have been active */ if pdata (proc_number).online | pdata (proc_number).offline then substr (proc_exists_mask, proc_number + 1, 1) = "1"b; end; prds_processor = prds_processor & proc_exists_mask; end setup_from_scs; %page; /* Internal procedure to check a named location for valid machine conditions. If machine conditions are stored, they are copied to temporary storage, and a pointer to the temporary storage area is returned */ validate_mc: proc (segptr, segname, mc_name,a_mc_ptr, a_scu_ptr); dcl a_mc_ptr ptr; dcl a_scu_ptr ptr; dcl segptr ptr; /* pointer to base of copy of segment */ dcl segname char (*); /* segment name */ dcl mc_name char (*); /* entry name where machine conditions are stored */ dcl mcptr ptr; mcptr = ptr (segptr, amu_$definition_offset (amu_info_ptr, segname, mc_name, code)); if code ^= 0 then do; call amu_$error_for_caller ((null ()), code, MYNAME, "Cannot find ^a$^a in dump.", segname, mc_name); end; if mcptr = null () then goto mc_data_not_valid; if string (mcptr -> mc.scu) = "0"b then goto mc_data_not_valid; a_scu_ptr = copy_to_temporary (addr(mcptr -> mc.scu), size (scu)); a_mc_ptr = mcptr; return; mc_data_not_valid: a_mc_ptr = null (); a_scu_ptr = null (); end validate_mc; %page; /* Internal procedure to validate a stack pointer and construct a pointer to it. The pointer is checked to contain the segment number of the stack, to point to a mod-16 location, and to be within the bounds defined by the stack_end_ptr. A pointer to the frame in the copy of the stack is constructed */ validate_stack_ptr: proc (stack_ptr, seg_num, stack_base_ptr) returns (fixed bin (18)); dcl stack_ptr ptr; /* stack pointer from FDUMP */ dcl seg_num fixed bin; /* segment number of stack in FDUMP */ dcl stack_base_ptr ptr; /* pointer to copy of stack */ if baseno (stack_ptr) = "077777"b3 then /* if null ptr */ return (-1); /* return */ if addr (stack_ptr) -> its.mod then return (-1); /* return */ if addr (stack_ptr) -> its.bit_offset then return (-1); /* return */ if addr (stack_ptr) -> its.its_mod ^= ITS_MODIFIER then return (-1); if bin (baseno (stack_ptr)) ^= seg_num | bin (rel (stack_ptr)) >= bin (rel (stack_base_ptr -> stack_header.stack_end_ptr)) | mod (bin (rel (stack_ptr)), 16) ^= 0 | bin (rel (stack_ptr)) < bin (rel (stack_base_ptr -> stack_header.stack_begin_ptr)) | rel (stack_ptr) = "0"b then return (-1); return (fixed (rel (stack_ptr),18)); end validate_stack_ptr; %page; /* Internal procedure to walk a stack looking for fim-frames the walk is done forward, and only frames within the current segment are considered (there really shouldn't be any outside of it) */ walk_stack: proc (stack_seg, stack_name); dcl stack_seg fixed bin; /* segment number of stack */ dcl stack_name char (*); /* name of stack */ dcl the_hard_way bit (1); dcl data1 char (d1_len) based; dcl data2 char (d2_len) based; dcl data3 char (d3_len) based; dcl (d1_len,d2_len,d3_len) fixed bin (21); dcl min_length fixed bin; dcl fm_scup ptr; dcl len fixed bin (21); dcl loop_count fixed bin; dcl next_frame_mc bit (1); dcl seg_offset char (13); dcl sp_offset fixed bin (18); dcl stack_frame_sw bit (1); dcl stack_frame_save (min_length) fixed bin (36) based (sp); dcl stack_header_sw bit (1); dcl (sp_save,sb_save) ptr; dcl (illegal_modifier,fault_tag_1) condition; on illegal_modifier begin; goto stack_err_cond; end; on fault_tag_1 begin; goto stack_err_cond; end; code = 0; stack_header_sw,stack_frame_sw,the_hard_way = "0"b; translation_ptr = get_trans (stack_seg); if translation_ptr = null () then return; sb = translation.part1.ptr; if translation.flags.two_part then do; if translation.part1.lth < size(stack_header) then do; allocate stack_header in (amu_area) set (sb); d1_len = translation.part1.lth * 4; d2_len = (size(stack_header) - translation.part1.lth) * 4; d3_len = size(stack_header) * 4; sb -> data3 = translation.part1.ptr -> data1 || translation.part2.ptr -> data2; sp_offset = validate_stack_ptr (stack_header.stack_begin_ptr, stack_seg, sb); the_hard_way = "1"b; sb_save = sb; stack_header_sw = "1"b; end; end; if ^stack_header_sw then sp_offset = validate_stack_ptr (stack_header.stack_begin_ptr, stack_seg, sb); if sp_offset = -1 then goto stack_done; loop_count = 1000; next_frame_mc = "0"b; min_length = stack_frame_min_length + size(mc); if the_hard_way then goto do_the_hard_way; do sp_offset = sp_offset repeat validate_stack_ptr (stack_frame.next_sp, stack_seg, sb) while (sp_offset ^= -1 & loop_count > 0); if translation.flags.two_part then if (sp_offset + min_length) > translation.part1.lth then goto do_the_hard_way; sp = addrel (sb,sp_offset); mcp = null (); if next_frame_mc | valid_fim_ptr (stack_frame.return_ptr) then do; mcp = addrel (sp, stack_frame_min_length); if addr (mc.scu (0)) -> scu.ppr.psr ^= "0"b then do; call ioa_$rsnnl ("^a|^o", seg_offset, len, stack_name, sp_offset); fm_scup = copy_to_temporary (addr(mc.scu), size (scu)); call add_an_event (bin (mc.fault_time, 71), fm_scup, print_mc, seg_offset, "0"b, "0"b); end; end; next_frame_mc = "0"b; if stack_frame_flags.signaller then next_frame_mc = "1"b; loop_count = loop_count - 1; end; goto stack_done; do_the_hard_way: if sp_offset < translation.part1.lth then do; allocate stack_frame_save in (amu_area) set (sp); d3_len = min_length * 4; d1_len = (translation.part1.lth - sp_offset) * 4; d2_len = d3_len - d1_len; sp -> data3 = addrel(translation.part1.ptr,sp_offset) -> data1 || translation.part2.ptr -> data2; stack_frame_sw = "1"b; sp_save = sp; goto jump_in; end; do sp_offset = sp_offset repeat validate_stack_ptr (stack_frame.next_sp, stack_seg, sb) while (sp_offset ^= -1 & loop_count > 0); sp = addrel (translation.part2.ptr,(sp_offset - translation.part1.lth)); jump_in: mcp = null (); if next_frame_mc | valid_fim_ptr (stack_frame.return_ptr) then do; mcp = addrel (sp, stack_frame_min_length); if addr (mc.scu (0)) -> scu.ppr.psr ^= "0"b then do; call ioa_$rsnnl ("^a|^o", seg_offset, len, stack_name,sp_offset); fm_scup = copy_to_temporary (addr(mc.scu), size (scu)); call add_an_event (bin (mc.fault_time, 71), fm_scup, print_mc, seg_offset, "0"b, "0"b); end; end; next_frame_mc = "0"b; if stack_frame_flags.signaller then next_frame_mc = "1"b; loop_count = loop_count - 1; end; stack_done: revert fault_tag_1; revert illegal_modifier; if stack_frame_sw then free sp_save -> stack_frame_save in (amu_area); if stack_header_sw then free sb_save -> stack_header in (amu_area); code = 0; return; stack_err_cond: call ssu_$print_message (sci_ptr,0, "The ^a in process ^d contains invalid data.", stack_name, proc_no); goto stack_done; end walk_stack; %page; valid_fim_ptr: proc (t_ptr) returns (bit (1)); dcl t_ptr ptr; dcl its_ptr ptr; if bound_interceptors_ptr = null () then return ("0"b); its_ptr = addr(t_ptr); if its_ptr -> its.its_mod ^= ITS_MODIFIER then return ("0"b); if its_ptr -> its.mod ^= "0"b then return ("0"b); if its_ptr -> its.segno ^= baseno(bound_interceptors_ptr) then return ("0"b); return ("1"b); end valid_fim_ptr; %page; mh_or_ex: proc (long_data); dcl long_data bit (1) parameter; if long_data then do; if (good_match) then call ioa_ ("^a", temp_string); return; end; temp_string = temp_time || temp_string; good_match = match_strings_$test (match_info_ptr, rtrim(temp_string)); if (good_match) then call ioa_ ("^a", temp_string); else if num_events > -1 then events_printed = events_printed - 1; return; end mh_or_ex; %page; %include amu_fdump_info; %page; %include amu_hardcore_info; %page; %include amu_info; %page; %include amu_translation; %page; %include apte; %page; %include bind_map; %page; %include bos_dump; %page; %include dskdcl; %page; %include fs_dev_types; %page; %include iom_data; %page; %include its; %page; %include mc; %page; %include mc_trace_buf; %page; %include object_info; %page; %include pvt; %page; %include pvte; %page; %include scs; %page; %include slt; %page; %include stack_frame; %page; %include stack_header; %page; %include syserr_data; %page; %include log_message; %page; %include log_segment; end azm_display_fdump_events;  azm_display_mc_.pl1 11/19/84 1143.5rew 11/15/84 1440.1 231624 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ azm_display_mc_: proc (P_sci_ptr, P_amu_info_ptr, P_mc_ptr, P_arg_bits_ptr, P_code); /* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */ /* Routine to display machine conditions or portions of machine condition frames for analyze_multics */ /* Written December 1981 by Rich Coppola Modified 19 Jan 84 by BLB to call a temp seg with sci_ptr and not amu_info.sci_ptr. Modified 29 Sept 84 by BLB to check all words of SCU data for zeros before aborting. (azm error 11). Modified Sept 84 by R. A. Fawcett to remove some of the blank lines in output Modified 01 Oct 84 by BLB to stop using decimal_date_time_. */ /* PARAMETERS */ dcl P_amu_info_ptr ptr; /* ptr to amu info */ dcl P_mc_ptr ptr; /* ptr to thr mc BLOCK */ dcl P_sci_ptr ptr; dcl P_arg_bits_ptr ptr; /* ptr to bit array defining the type of display desired */ dcl P_code fixed bin (35); /* error code if any */ /* EXTERNAL ENTRIES */ dcl db_print entry (ptr, char (32), ptr, char (*) aligned, fixed bin, fixed bin, ptr, fixed bin, fixed bin); dcl iox_$user_output ptr ext static; dcl cv_bin_$oct entry (fixed bin, char (12) aligned); dcl ( ioa_, ioa_$rsnnl ) entry options (variable); dcl amu_$get_name entry (ptr, ptr) returns (char (*)); dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl ssu_$get_temp_segment entry (ptr, char(*), ptr); dcl ssu_$release_temp_segment entry (ptr, ptr); /* AUTOMATIC */ dcl error_code_mc fixed bin (35); dcl iocb_name char (32); dcl iocbp ptr; dcl (by_name, ref_name) char (168); dcl eis_info_valid bit (1); dcl (line1, line2) char (80) varying; dcl (line1_sw, line2_sw) bit (1) init ("0"b); dcl at_by_wd char (2); dcl cvbinbuf char (12) aligned; dcl aligned_error_message char (100) aligned; dcl (i, j) fixed bin; dcl code fixed bin (35); dcl time char (24); dcl tsrpr bit (1); dcl print_ia bit (1); dcl (byptr, refptr) ptr; dcl (lnpos, flt_lng, inst6) fixed bin; dcl (no_scu_data, non_val_flt) bit (1); dcl fault_index fixed bin (6) unsigned; dcl temp_index fixed bin; dcl fltdtab (0:35) bit (1) based (byptr) unaligned; dcl (flt_ln, FLT_LN, IA_LN) char (100); dcl flt_bf char (24) varying; dcl sci_ptr ptr; dcl 1 pwrd based (PR_ptr) aligned, 2 w1 fixed bin (35), 2 w2 fixed bin (35); dcl PTR_STR char (24) aligned; dcl PR_ptr ptr; /* temp ptr for PR display */ dcl TAG_ptr ptr; /* pointer to tag table */ dcl tag_prt bit (1) init ("0"b); dcl tag_ char (4) init (""); dcl 1 TAG (64) based (TAG_ptr), 2 code char (4) unal, 2 pad bit (8) unal, 2 chain bit (1); dcl (addr, addrel, baseptr, bin, fixed, length, hbound, lbound, null, rtrim, string, substr, unspec) builtin; dcl cleanup condition; %page; /* CONSTANTS */ dcl TAG_table (8) char (40) int static options (constant) init (/* tag table */ " au qu du ic al ql dl ", "x0 x1 x2 x3 x4 x5 x6 x7 ", "n* aau* aqu* ailtg ic* aal* aql* ailtg ", "0* a1* a2* a3* a4* a5* a6* a7* a", "fi itp iltg its sd scr f2 f3 ", "ci i sc ad di dic aid idc a", "*n *au *qu iltg *ic *al *ql iltg ", "*0 *1 *2 *3 *4 *5 *6 *7 "); dcl cpul (0:7) char (1) int static options (constant) init ("a", "b", "c", "d", "e", "f", "g", "h"); dcl ptrfmt char (44) int static options (constant) init ("PR^o (^[ap^;ab^;bp^;bb^;lp^;lb^;sp^;sb^]) - "); dcl port_name (4) char (3) int static options (constant) init ("A: ", "B: ", "C: ", "D: "); dcl FAULT_TYPES (36) char (15) var int static options (constant) init ("ILL OP", "ILL MOD", "ILL SLV", "ILL PROC", "NEM", "OOB", "WRT INH", "PROC PAR-UPR", "PROC PAR-LWR", "$CON A", "$CON B", "$CON C", "$CON D", "ONC (DA ERR1)", "ONC (DA ERR2)", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "CACHE-PAR DIR", "CACHE-PAR STR", "CACHE-PAR IA", "CACHE-PAR BLK"); dcl SC_IA_TYPES (1:15) char (42) var int static options (constant) init ("Unassigned (01)", "Non-existent Address (02)", "Stop on Condition (03)", "Unassigned (04)", "Data Parity, Store to SC (05)", "Data Parity in Store (06)", "Data Parity in Store AND Store to SC (07)", "Not Control (10)", "Port Not Enabled (11)", "Illegal Command (12)", "Store Not Ready ( 13)", "ZAC Parity, Active Module to SC (14)", "Data Parity, Active Module to SC (15)", "ZAC Parity, SC to Store (16)", "Data Parity, SC to Store (17)"); dcl EXT_FAULT_TYPES (15) char (39) var int static options (constant) init ("Bffr. Ovflw - Port A", "Bffr. Ovflw - Port B", "Bffr. Ovflw - Port C", "Bffr. Ovflw - Port D", "Bffr. Ovflw - Primary Dir", "Write Notify Parity Error on ANY Port", "Dup. Dir. LVL 0 Parity Error", "Dup. Dir. LVL 1 Parity Error", "Dup. Dir. LVL 2 Parity Error", "Dup. Dir. LVL 3 Parity Error", "Dup. Dir. Multi Match Error", "PTW Ass. Mem. Parity Error", "PTW Ass. Mem. Match Error", "SDW Ass. Mem. Parity Error", "SDW Ass. Mem. Match Error"); dcl ill_act (0:15) char (37) varying int static options (constant) init ("...", "Unassigned", "Non Existent Address", "Fault on Condition", "Unassigned", "Data Parity (Store -> SCU)", "Data Parity in Store", "Data Parity (Store -> SCU & in Store)", "Not Control", "Port Not Enabled", "Illegal Command", "Store Not Ready", "ZAC Parity (Processor -> SCU)", "Data Parity (Processor -> SCU)", "ZAC parity (SCU -> Store)", "Data Parity (SCU -> Store)"); dcl indrs (18:31) char (4) varying int static options (constant) init ("zero", "neg", "cary", "ovfl", "eovf", "eufl", "oflm", "tro", "par", "parm", "^bar", "tru", "mif", "abs"); dcl APU (18:32) char (6) varying int static options (constant) init ("priv", "xsf", "sdwamm", "sd-on", "ptwamm", "pt-on", "pi-ap", "dsptw", "sdwnp", "sdwp", "ptw", "ptw2", "fap", "fanp", "fabs"); dcl CU (18:29) char (3) varying int static options (constant) init ("rf", "rpt", "rd", "rl", "pot", "pon", "xde", "xdo", "itp", "rfi", "its", "fif"); dcl g1and7flts (5) bit (6) int static options (constant) unaligned init ("01"b3, "11"b3, "21"b3, "31"b3, "37"b3); dcl grp1flt (0:19) char (24) varying int static options (constant) init ("Illegal Ring Order", "Not in Execute Bracket", "Execute Bit off", "Not In Read Bracket", "Read Bit Off", "Not In Write Bracket", "Write Bit Off", "Not A Gate", "Not In Call Bracket", "Outward Call", "Bad Outward Call", "Inward Return", "Cross Ring Transfer", "Ring Alarm", "Associative Memory", "Out of Segment Bounds", "Processor Parity Upper", "Processor Parity Lower", "SC To Proc. Seq. Error 1", "SC To Proc. Seq. Error 2"); dcl grp2flt (0:6) char (24) varying int static options (constant) init ("Illegal Segment Number", "Illegal Op Code", "Illegal Address & Mod", "Illegal Slave Procedure", "Illegal Procedure", "Non Existent Address", "Out Of Bounds"); dcl flt_int_typ (0:63) char (24) varying int static options (constant) init ("...", "Shutdown", "...", "Store", "Bulk Store 0 Term", "MME 1", "...", "Fault Tag 1", "IOM 0 Overhead", "Timer Runout", "IOM 1 Overhead", "Command", "IOM 2 Overhead", "Derail", "IOM 3 Overhead", "Lockup", "IOM 0 Terminate Ch 40-77", "Connect", "IOM 1 Terminate Ch 40-77", "Parity", "Bulk Store 1 Term", "Illegal Procedure", "...", "Op Not Complete", "IOM 0 Terminate", "Startup", "IOM 1 Terminate", "Overflow", "IOM 2 Terminate", "Divide Check", "IOM 3 Terminate", "Execute", "IOM 0 Marker Ch 40-77", "(DF0) Segment", "IOM 1 Marker Ch 40-77", "(DF1) Page", "...", "Directed Fault 2", "...", "Directed Fault 3", "IOM 0 Marker", "Access Violation", "IOM 1 Marker", "MME 2", "IOM 2 Marker", "MME 3", "IOM 3 Marker", "MME 4", "...", "(FT2) Linkage", "...", "Fault Tag 3", "...", "...", "...", "...", "IOM 0 Special", "...", "IOM 1 Special", "...", "IOM 2 Special", "...", "IOM 3 Special", "Trouble"); %page; call setup; on condition(cleanup) begin; if arg_bits_def.dump then call ssu_$release_temp_segment (sci_ptr, mcp); end; if arg_bits_def.dump then do; /* display the mc from the bos dump */ call init_dump_display; if code ^= 0 then do; P_code = code; return; end; end; else do; /* set up the vars for the scu data */ scup = addr (mc.scu); call init_scu_data; if no_scu_data then do; arg_bits_def.mc_stored = "0"b; call ioa_ ("No SCU data stored."); return; end; else arg_bits_def.mc_stored = "1"b; end; start_display: if arg_bits_def.all then do; /* display all the mc from the given pointer */ call display_pr_regs_; if code ^= 0 then goto error_return; call display_regs_; if code ^= 0 then goto error_return; call ioa_ ("^a^[^/^a^]", FLT_LN,print_ia, IA_LN); call display_scu_; if code ^= 0 then goto error_return; call display_misc_; if code ^= 0 then goto error_return; if eis_info_valid then do; call display_eis_info_; if code ^= 0 then goto error_return; end; return; end; call ioa_ ("^a^[^/^a^]", FLT_LN,print_ia, IA_LN); if arg_bits_def.prs then do; call display_pr_regs_; if code ^= 0 then goto error_return; goto bypass_prs; end; do i = 0 to 7; if arg_bits_def.pr (i) then call print_pr_reg (i); if code ^= 0 then goto error_return; end; bypass_prs: if arg_bits_def.regs then do; call display_regs_; if code ^= 0 then goto error_return; goto by_pass_reg; end; do i = 0 to 7; if xreg (i) then call display_x_reg (i); end; if arg_bits_def.areg then call display_aq_reg ("1"b); if arg_bits_def.qreg then call display_aq_reg ("0"b); by_pass_reg: if arg_bits_def.scu then do; call display_scu_; if code ^= 0 then goto error_return; call display_mc_code; goto bypass_ppr_tpr; end; else do; if arg_bits_def.ppr then call print_ppr; if arg_bits_def.tpr then call print_tpr; if arg_bits_def.inst then call print_inst; end; bypass_ppr_tpr: if arg_bits_def.mis then do; call display_misc_; goto bypass_misc; end; else do; if arg_bits_def.mc_err then call display_mc_code; if arg_bits_def.flt then do; call interpret_fault_reg (mc.fault_reg); if mc.cpu_type = 1 then if mc.ext_fault_reg ^= "0"b then call interpret_ext_fault_reg (mc.ext_fault_reg); end; if arg_bits_def.tm then call display_time; end; bypass_misc: if arg_bits_def.eis then do; call display_eis_info_; if code ^= 0 then goto error_return; end; if arg_bits_def.dump then call ssu_$release_temp_segment (sci_ptr, mcp); return; %page; azm_display_mc_$regs_only: entry (P_sci_ptr, P_amu_info_ptr, P_mc_ptr, P_arg_bits_ptr, P_code); call setup; call display_pr_regs_; if code ^= 0 then goto error_return; call display_regs_; if code ^= 0 then goto error_return; P_code = 0; return; %page; setup: proc; amu_info_ptr = P_amu_info_ptr; sci_ptr = P_sci_ptr; arg_bits_ptr = P_arg_bits_ptr; mcp = P_mc_ptr; iocbp = iox_$user_output; P_code, code = 0; end setup; %page; init_scu_data: proc; scup = addr (mc.scu); no_scu_data, non_val_flt, eis_info_valid, print_ia = "0"b; if ^arg_bits_def.dump then if string(scu) = "0"b then do; no_scu_data = "1"b; return; end; inst6 = 6; fault_index = fixed (scu.fi_num || scu.fi_flag, 6); FLT_LN, flt_ln, flt_bf = ""; tsrpr = "0"b; flt_bf = flt_int_typ (fault_index); if substr (flt_bf, 1, 3) = "..." then non_val_flt = "1"b; else do; flt_lng = length (flt_int_typ (fault_index)); substr (flt_ln, 1, flt_lng) = substr (flt_bf, 1, flt_lng); byptr = addrel (scup, 1); if fltdtab (35) = "1"b then do; substr (flt_ln, flt_lng + 2, 5) = "Fault"; lnpos = flt_lng + 8; do i = 1 to hbound (g1and7flts, 1); /* If grp 1 or 7 faults, don't print out tsr|ca */ if unspec (fault_index) = g1and7flts (i) then tsrpr = "1"b; end; end; else do; substr (flt_ln, flt_lng + 2, 9) = "Interrupt"; lnpos = flt_lng + 12; tsrpr = "1"b; /* don't print out tsr|ca for interrupts */ end; temp_index = fault_index; call cv_bin_$oct (temp_index, cvbinbuf); substr (flt_ln, lnpos, 4) = "(" || substr (cvbinbuf, 11, 2) || ")"; lnpos = lnpos + 4; j = lnpos; do i = 0 to hbound (grp1flt, 1); if fltdtab (i) then do; if substr (flt_ln, 1, 5) = "Store" | substr (flt_ln, 1, 12) = "Illegal Proc" then if i <= 6 then call ioa_$rsnnl ("^a, ^a", flt_ln, j, flt_ln, grp2flt (i)); else ; else call ioa_$rsnnl ("^a, ^a", flt_ln, j, flt_ln, grp1flt (i)); end; end; FLT_LN = flt_ln; end; if scu.port_stat.ial ^= "0"b then do; /* display illegal action lines if present */ call ioa_$rsnnl ("Illegal Action Code (^o) - ^a", IA_LN, j, fixed (scu.port_stat.ial, 4), ill_act (fixed (scu.port_stat.ial, 4))); print_ia = "1"b; end; if tsrpr then at_by_wd = "At"; /* if not printing tsr */ else at_by_wd = "By"; if scu.ir.mif then eis_info_valid = "1"b; else eis_info_valid = "0"b; return; end init_scu_data; %page; /* dump - internal proc to display registers saved at time of dump */ init_dump_display: proc; call ssu_$get_temp_segment (sci_ptr, "azm_display_mc", mcp); call ioa_ ("^/Bootload CPU Registers at Time of Dump:"); dumpptr = P_mc_ptr; unspec (mc.prs) = unspec (dump.prs); unspec (mc.regs) = unspec (dump.regs); unspec (mc.scu) = unspec (dump.misc_registers.scu); unspec (mc.mask) = unspec (dump.misc_registers.mcm); mc.fault_reg = dump.faultreg; mc.ext_fault_reg = dump.ext_fault_reg; mc.eis_info = dump.ptrlen; call ioa_ ("Descriptor Segment Base Register: ^12.3b ^12.3b", substr (dump.dbr, 1, 36), substr (dump.dbr, 37, 36)); if dump.modereg ^= "0"b then call ioa_ ("Mode Register: ^12.3b", dump.modereg); if dump.cmodereg ^= "0"b then call ioa_ ("Cache Mode Register: ^12.3b", dump.cmodereg); if dump.bar ^= "0"b then call ioa_ ("Base Address Register: ^12.3b", dump.bar); call init_scu_data; return; end init_dump_display; %page; /* display_regs - internal proc to display processor registers included in machine conditions */ display_regs_: proc; call ioa_ ("Processor Registers:"); call ioa_ ("^3xX0 - ^o X1 - ^o X2 - ^o X3 - ^o^/^3xX4 - ^o X5 - ^o X6 - ^o X7 - ^o", fixed (mc.regs.x (0), 18), fixed (mc.regs.x (1), 18), fixed (mc.regs.x (2), 18), fixed (mc.regs.x (3), 18), fixed (mc.regs.x (4), 18), fixed (mc.regs.x (5), 18), fixed (mc.regs.x (6), 18), fixed (mc.regs.x (7), 18)); call ioa_ ("^3xA Register - ^12.3b Q Register - ^12.3b E Register - ^o", mc.regs.a, mc.regs.q, fixed (mc.regs.e, 8)); call ioa_ ("^3xTimer Register - ^9.3b Ring Alarm Register - ^1.3b", mc.t, mc.ralr); return; end display_regs_; display_x_reg: proc (i); dcl i fixed bin; call ioa_ ("X^1d ^o", i, fixed (mc.regs.x (i), 18)); end display_x_reg; display_aq_reg: proc (a); dcl a bit (1); if a then call ioa_ ("A REG ^12.3b", mc.regs.a); else call ioa_ ("Q REG ^12.3b", mc.regs.q); end display_aq_reg; %page; display_misc_: proc; if mc.mask ^= "0"b then call ioa_ ("Mem Controller Mask: ^12.3b ^12.3b", substr (mask, 1, 36), substr (mask, 37, 36)); call display_mc_code; call interpret_fault_reg (mc.fault_reg); if mc.cpu_type = 1 then if mc.ext_fault_reg ^= "0"b then call interpret_ext_fault_reg (mc.ext_fault_reg); call display_time; end display_misc_; %page; display_time: proc; dcl dt_form char(41) int static options(constant) init( "^yc-^my-^dm ^Hd:^MH:^SM.^US ^xxxxza^xxxda"); dcl date_time_$format entry(char(*), fixed bin(71), char(*), char(*)) returns(char(250) var); call ioa_ ("MC Fault Time: ^a (^18.3b)", date_time_$format(dt_form, fixed (mc.fault_time, 71),"",""), mc.fault_time); end display_time; display_mc_code: proc; if mc.errcode ^= 0 then do; error_code_mc = mc.errcode; call convert_status_code_ (error_code_mc, (""), aligned_error_message); call ioa_ ("MC.ERRCODE:^/^a", rtrim (aligned_error_message)); end; end display_mc_code; %page; /* display_eis_info, internal proc to display Eis pointers and lengths */ display_eis_info_: proc; dcl eis_info_ptr ptr; dcl 1 eis_info_fmt based (eis_info_ptr), 2 mbz1 bit (9) unal, 2 neg_over bit (1) unal, 2 pd1 bit (2) unal, 2 char_tally bit (24) unal, 2 empty_word bit (36) unal, 2 dec1, 3 cur_wd_off bit (18) unal, 3 cur_char_off bit (2) unal, 3 cur_bit_off bit (4) unal, 3 pd2 bit (1) unal, 3 data_mode bit (2) unal, 3 pd3 bit (3) unal, 3 ingore_seg bit (1) unal, 3 first_time_used bit (1) unal, 3 active bit (1) unal, 3 pd4 bit (3) unal, 3 level_count bit (9) unal, 3 pd5 bit (3) unal, 3 residue fixed bin (23) signed unal, 2 dec2, 3 cur_wd_off bit (18) unal, 3 cur_char_off bit (2) unal, 3 cur_bit_off bit (4) unal, 3 d2pd1 bit (1) unal, 3 data_mode bit (2) unal, 3 d2pd2 bit (3) unal, 3 rpt_cycle bit (1) unal, 3 or_d2du_first bit (1) unal, 3 active bit (1) unal, 3 d2pd3 bit (1) unal, 3 first_time bit (1) unal, 3 d2du bit (1) unal, 3 d2mbz bit (9) unal, 3 d2pd4 bit (3) unal, 3 residue fixed bin (23) signed unal, 2 dec3, 3 cur_wd_off bit (18) unal, 3 cur_char_off bit (2) unal, 3 cur_bit_off bit (4) unal, 3 d3pd1 bit (1) unal, 3 data_mode bit (2) unal, 3 d3pd2 bit (3) unal, 3 rpt_cycle bit (1) unal, 3 first_time bit (1) unal, 3 active bit (1) unal, 3 jump_add_ind bit (3) unal, 3 mbz bit (9) unal, 3 d3pd3 bit (3) unal, 3 residue fixed bin (23) signed unal; dcl three_desc bit (3) init ("100"b) static options (constant); call ioa_ ("EIS Pointers and Lengths:^/"); eis_info_ptr = addr (mc.eis_info); if eis_info_fmt.char_tally ^= "0"b then call ioa_ ("^5xTally count = ^8.3b", eis_info_fmt.char_tally); if dec1.active then do; call ioa_ ("^-DESC1 active "); if scu.tsr_stat.tsna.prv then call ioa_ ("^-^2xUsing PR^1.3b segment number ^o", scu.tsr_stat.tsna.prn, substr (unspec (mc.prs (fixed (scu.tsr_stat.tsna.prn, 3))), 4, 15)); call ioa_ ("^-Cur word ptr ^6.3b char ^1.2b bit ^4b^/^-^2x data_mode ^d, level_count ^d, residue ^d", dec1.cur_wd_off, dec1.cur_char_off, dec1.cur_bit_off, fixed (dec1.data_mode, 2), fixed (dec1.level_count, 8), dec1.residue); end; else do; call ioa_ ("^-DESC1 inactive"); end; if dec2.active then do; call ioa_ ("^-DESC2 active "); if scu.tsr_stat.tsnb.prv then call ioa_ ("^-^2xUsing PR^1.3b segment number ^o", scu.tsr_stat.tsnb.prn, substr (unspec (mc.prs (fixed (scu.tsr_stat.tsnb.prn, 3))), 4, 15)); call ioa_ ("^-Cur word ptr ^6.3b, char ^2b ^4b^/^-^2x data_mode ^d, residue ^d", dec2.cur_wd_off, dec2.cur_char_off, dec2.cur_bit_off, fixed (dec2.data_mode, 2), fixed (dec2.residue, 23)); end; else do; call ioa_ ("^-DESC2 inactive"); end; if dec3.jump_add_ind ^= three_desc then goto eis_oct; if dec3.active then do; call ioa_ ("^-DESC3 active "); if scu.tsr_stat.tsnc.prv then call ioa_ ("^-^2xUsing PR^1.3b segment number ^o", scu.tsr_stat.tsnc.prn, substr (unspec (mc.prs (fixed (scu.tsr_stat.tsnc.prn, 3))), 4, 15)); call ioa_ ("^-Cur word ptr ^6.3b, char ^2b ^4b^/^-^2x residue ^d", dec3.cur_wd_off, dec3.cur_char_off, dec3.cur_bit_off, fixed (dec3.residue, 23)); end; else do; call ioa_ ("^-DESC3 inactive"); end; eis_oct: if arg_bits_def.long then call ioa_ ("^-^4(^w ^)^/^-^4(^w ^)", mc.eis_info (0), mc.eis_info (1), mc.eis_info (2), mc.eis_info (3), mc.eis_info (4), mc.eis_info (5), mc.eis_info (6), mc.eis_info (7)); return; end display_eis_info_; %page; /* display_pr_regs - internal proc to display pointer registers */ display_pr_regs_: proc; dcl i fixed bin; call ioa_ ("Pointer Registers:"); do i = 0 to 7; call print_pr_reg (i); end; return; end display_pr_regs_; print_pr_reg: proc (i); dcl i fixed bin; PR_ptr = addr (mc.prs (i)); if PR_ptr -> its.its_mod ^= "100011"b then call ioa_ (ptrfmt || "^w ^w", i, i + 1, pwrd.w1, pwrd.w2); else do; call ioa_$rsnnl (ptrfmt || "^p", PTR_STR, j, i, i + 1, mc.prs (i)); call ioa_ ("^3x^22a ^a", PTR_STR, amu_$get_name (amu_info_ptr, mc.prs (i))); if arg_bits_def.long then call ioa_ ("^-^5x^w ^w", pwrd.w1, pwrd.w2); end; end print_pr_reg; %page; display_scu_: proc; call ioa_ ("SCU Data:"); if arg_bits_def.long then /* user wants octal dump too */ call ioa_ ("^-^4(^w ^)^/^-^4(^w ^)^/", mc.scu (0), mc.scu (1), mc.scu (2), mc.scu (3), mc.scu (4), mc.scu (5), mc.scu (6), mc.scu (7)); if non_val_flt then call ioa_ ("Fault/Interrupt (^o), Undefined", fault_index); call print_ppr; if ^tsrpr then call print_tpr; call ioa_ ("On: cpu ^a (#^o)", cpul (fixed (scu.cpu_no, 3)), fixed (scu.cpu_no, 3)); flt_ln = ""; byptr = addr (scu.ilc); /* display Indicator register if any bits present */ do i = lbound (indrs, 1) to hbound (indrs, 1); if fltdtab (i) then call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, indrs (i)); end; if flt_ln ^= "" then do; substr (flt_ln, j, 1) = " "; call ioa_ ("Indicators: ^a", flt_ln); flt_ln = ""; end; byptr = addr (scu.ppr); /* display interpreted APU status if any bits present */ do i = lbound (APU, 1) to hbound (APU, 1); if fltdtab (i) then call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, APU (i)); end; if flt_ln ^= "" then do; substr (flt_ln, j, 1) = " "; call ioa_ ("APU Status: ^a", flt_ln); flt_ln = ""; end; byptr = addr (scu.ca); /* display interprted CU status if any bits present */ do i = lbound (CU, 1) to hbound (CU, 1); if fltdtab (i) then call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, CU (i)); end; TAG_ptr = addr (TAG_table); i = fixed (scu.cpu_tag, 6); if i ^= 0 then do; tag_ = TAG.code (i + 1); tag_prt = "1"b; end; if (flt_ln ^= "") | (tag_ ^= "") then do; substr (flt_ln, j, 1) = " "; call ioa_ ("CU Status: ^a ^[^/CT Hold: ^a^]", flt_ln, tag_prt, tag_); end; call print_inst; return; end display_scu_; %page; print_ppr: proc; byptr = addrel (baseptr (fixed (scu.ppr.psr, 18)), fixed (scu.ilc, 18)); by_name = amu_$get_name (amu_info_ptr, byptr); call ioa_ ("^a: ^p ^a", at_by_wd, byptr, by_name); end print_ppr; print_tpr: proc; refptr = addrel (baseptr (fixed (scu.tpr.tsr, 18)), fixed (scu.ca, 18)); ref_name = amu_$get_name (amu_info_ptr, refptr); call ioa_ ("Ref: ^p ^a", refptr, ref_name); end print_tpr; print_inst: proc; iocb_name = iocbp -> iocb.name; call ioa_ ("Instructions: "); /* display Instructions (words 6 & 7) */ call db_print (iocbp, iocb_name, addr (scu.even_inst), "i", inst6, 1, null, 0, 0); call db_print (iocbp, iocb_name, addr (scu.odd_inst), "i", inst6 + 1, 1, null, 0, 0); end print_inst; /* Internal procedure to print fault reg data */ interpret_fault_reg: proc (fault_reg); dcl fault_reg bit (36); dcl (fault_no, break) fixed bin; dcl 1 illeg_acts based (addr (fault_reg)), ( 2 pad bit (16), 2 IA (4) bit (4), 2 pad1 bit (4) ) unal; if fault_reg = "0"b then return; line1, line2 = ""; do fault_no = 1 to 15; if substr (fault_reg, fault_no, 1) = "1"b then do; line1 = line1 || FAULT_TYPES (fault_no) || ", "; line1_sw = "1"b; end; end; break = 0; do fault_no = 1 to 4 while (break = 0); /* do IAs now */ if IA (fault_no) then do; line2 = "Illegal Action on CPU Port " || port_name (fault_no); line2 = line2 || SC_IA_TYPES (bin (IA (fault_no), 4)) || ", "; line2_sw = "1"b; break = 1; end; end; do fault_no = 33 to 36; if substr (fault_reg, fault_no, 1) = "1"b then do; line1 = line1 || FAULT_TYPES (fault_no) || ", "; line1_sw = "1"b; end; end; if line1_sw then /* remove trailing comma & space */ line1 = substr (line1, 1, (length (line1) - 2)); if line2_sw then line2 = substr (line2, 1, (length (line2) - 2)); call ioa_ ("Fault Register: ^12.3b^[ (^a)^;^s^]^[^/^17t(^a)^]", fault_reg, line1_sw, line1, line2_sw, line2); return; %page; end interpret_fault_reg; interpret_ext_fault_reg: proc (ext_fault_reg); dcl ext_fault_reg bit (15); dcl indx fixed bin; line1 = ""; do indx = 1 to 15; if substr (ext_fault_reg, indx, 1) = "1"b then line1 = line1 || EXT_FAULT_TYPES (indx) || ", "; end; if line1 ^= "" then do; line1 = substr (line1, 1, (length (line1) - 2)); call ioa_ ("DPS8 Extended Fault Register: ^5.3b (^a)", ext_fault_reg, line1); end; return; end interpret_ext_fault_reg; error_return: P_code = code; return; /* INCLUDE FILES */ %page; %include iocb; %page; %include bos_dump; %page; %include mc; %page; %include its; %page; %include amu_info; %page; %include amu_mc; end azm_display_mc_;  azm_dump_mem_.pl1 11/19/84 1143.5rew 11/15/84 1440.1 139869 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ azm_dump_mem_: proc (P_amu_info_ptr, P_address, P_indx, P_segno, P_offset, P_scu, P_abs_w, P_paged, P_code); /* Modified July 84 by B. Braun to add knowledge of unpaged_page_tables. Modified September 84 by B. Braun to add knowledge of int_unpaged_page_tables. Also, check all sdws whether cme.abs_w is true or not. */ /* Parameters */ dcl P_amu_info_ptr ptr, P_address fixed bin (24), P_indx fixed bin, P_segno fixed bin, P_offset fixed bin (18), P_scu fixed bin, P_abs_w bit (1), P_paged bit (1), P_code fixed bin (35); /* Automatic */ dcl add_sdw fixed bin (24), add_ptw fixed bin (24), aste_size fixed bin (18), bd_sdw fixed bin (24), code fixed bin (35), contr_ptr ptr, cme_size fixed bin (18), dseg_no fixed bin, found bit(1), i fixed bin (18), ignore fixed bin (21), j fixed bin (18), k fixed bin, loop_exit bit (1), mem_address fixed bin (24), mem_base fixed bin (24), mem_config_sw bit (1) init("0"b), mem_max fixed bin (24), mem_config bit (1), offset fixed bin (18), pds_dstep ptr, page_no fixed bin (18), pt_offset fixed bin (18), pt_size fixed bin (18), seg_offset fixed bin(18), save_process_index fixed bin, seg_name char (32), seg_no fixed bin, sst_base fixed bin (24), sst_segno fixed bin, str_segno fixed bin, str_size fixed bin (18), temp_dstep bit (18), temp_indx fixed bin, temp_ptr ptr, word_no fixed bin; /* Structures */ dcl 1 active_seg_table like aste; dcl 1 contr_data (0:7) like scs$controller_data; dcl 1 core_map like cme; dcl 1 hard_cur like hardcore_cur; dcl 1 ptw_a (0:255) like ptw; dcl 1 ptw_ab (0:255) like ptw based; dcl 1 page_table_word like ptw; dcl 1 seg_desc like sdw; dcl 1 seg_trailer like str; dcl 1 mem_conf_data (0:7), 2 base fixed bin, 2 data char (32); dcl 1 temp_conf like mem_conf_data; /* External */ dcl amu_$definition_ptr entry (ptr, char (*), char (*), fixed bin (35)) returns (ptr); dcl amu_$do_translation entry (ptr, fixed bin, ptr, fixed bin (18), fixed bin (18), fixed bin (35)); dcl amu_$do_translation_by_ptr entry (ptr, ptr, fixed bin (18), ptr, fixed bin (35)); dcl amu_$do_translation_hunt_ptr entry (ptr, ptr, ptr, fixed bin(35)); dcl amu_$fdump_mpt_change_idx entry (ptr, fixed bin); dcl amu_$hardcore_info_set_cur_ptrs entry (ptr, ptr); dcl amu_$return_val_per_process entry (ptr, fixed bin) returns (bit (1)); dcl amu_$slt_search_seg_num entry (ptr, ptr, char (32), fixed bin, fixed bin (35)); dcl (ioa_, ioa_$rsnnl) entry () options (variable); dcl amu_et_$free_core fixed bin (35) ext static; dcl amu_et_$non_existant_mem fixed bin(35) ext static; dcl amu_et_$proc_not_dumped fixed bin (35) ext static; dcl (addr, addrel, baseno, baseptr, divide, fixed, hbound, mod, null, pointer, rel, substr, size, unspec) builtin; %page; /* azm_dump_mem_ entry */ /* This entry translate the absolute address to a virtual address by looking at all sdws. P_amu_info_ptr amu_info pointer (input), P_address absolute memory address (input), P_indx process index (output), P_segno segno number of P_address (output), P_offset segno offset (output), P_scu system controller unit (output), P_abs_w "1"b if wired segment (output), P_paged "1"b if segment is paged (output), P_code error code (output). */ go to DUMP; azm_dump_mem_$mem_config: entry (P_amu_info_ptr, P_code); /* Prints the memory configuration */ mem_config_sw = "1"b; amu_info_ptr = P_amu_info_ptr; mem_address = 0; page_no = 0; word_no = 0; go to CONFIG; DUMP: amu_info_ptr = P_amu_info_ptr; mem_address = P_address; P_abs_w = "0"b; P_paged = "1"b; page_no = divide (mem_address, 1024, 21); word_no = mod (mem_address, 1024); CONFIG: code = 0; mem_config = "0"b; contr_ptr = addr (contr_data); temp_ptr = amu_$definition_ptr (amu_info_ptr, "scs", "controller_data", code); if code ^= 0 then do; P_code = code; return; end; call amu_$do_translation_by_ptr (amu_info_ptr, temp_ptr, size (contr_data), contr_ptr, code); if code ^= 0 then do; P_code = code; return; end; if mem_config_sw then go to MEM_CONF; do i = 0 to 7 while (^mem_config); if page_no >= contr_data (i).base then if page_no < (contr_data (i).base + contr_data (i).size) then if contr_data (i).info.online then mem_config = "1"b; end; if ^(mem_config) then do; P_code = amu_et_$non_existant_mem; return; end; if mem_config_sw then do; MEM_CONF: call ioa_ ("Memory Configuration:"); j = 0; do i = 0 to 7; if contr_data (i).online then do; mem_base = contr_data (i).base * 1024; mem_max = ((contr_data (i).size * 1024) -1) + mem_base; call ioa_$rsnnl ("^5xMem ^a ^8o to ^8o", mem_conf_data (j).data, ignore, substr ("ABCDEFGH", i + 1, 1), mem_base, mem_max); mem_conf_data (j).base = contr_data (i).base; j = j + 1; end; end; j = j - 1; do k = 0 to j - 1; do i = k + 1 to j; if mem_conf_data (i).base < mem_conf_data (k).base then do; temp_conf = mem_conf_data (k); mem_conf_data (k) = mem_conf_data (i); mem_conf_data (i) = temp_conf; end; end; end; do i = 0 to j; call ioa_ ("^a", mem_conf_data (i).data); end; return; end; /* get ptr to unpaged_page_tables and set hardcore current pointers */ hardcore_cur_ptr = addr (hard_cur); call amu_$hardcore_info_set_cur_ptrs (amu_info_ptr, hardcore_cur_ptr); upt_ptr = hardcore_cur.uptp; /* get the pointer to the core map */ temp_ptr = amu_$definition_ptr (amu_info_ptr, "sst", "cmp", code); if code ^= 0 then do; P_code = code; return; end; seg_no = fixed (baseno (temp_ptr), 17); sst_segno = seg_no; offset = fixed (rel (temp_ptr), 17); cme_size = 4; /* now get the core_map ptr in temp_ptr */ call amu_$do_translation (amu_info_ptr, seg_no, addr (temp_ptr), offset, 2, code); if code ^= 0 then do; P_code = code; return; end; offset = fixed (rel (temp_ptr), 18) + (page_no * cme_size); seg_no = fixed (baseno (temp_ptr), 17); cmep = addr (core_map); /* now get the cme */ call amu_$do_translation (amu_info_ptr, seg_no, cmep, offset, cme_size, code); if code ^= 0 then do; P_code = code; return; end; P_scu = fixed (cme.contr, 17); P_abs_w = cme.abs_w; /* search this process */ dseg_no = hardcore_info.segno.dseg; sdwp = addr (seg_desc); call amu_$do_translation (amu_info_ptr, dseg_no, sdwp, (sst_segno * 2), 2, code); if code ^= 0 then do; P_code = code; return; end; sst_base = fixed (sdw.add, 24); do i = 0 by 2 to (hardcore_info.hcs_count * 2); call amu_$do_translation (amu_info_ptr, dseg_no, sdwp, i, 2, code); if code ^= 0 then do; P_code = code; return; end; add_sdw = fixed (sdw.add, 24); bd_sdw = fixed (sdw.bound, 24) * 16; if sdw.unpaged then do; if (mem_address >= add_sdw) then do; if mem_address <= add_sdw + bd_sdw then do; P_segno = divide (i, 2, 17); P_offset = mem_address - add_sdw; P_indx = amu_info.process_idx; P_paged = "0"b; P_code = 0; return; end; end; end; else do; pt_size = divide (bd_sdw, 1024, 18); call get_ptp(add_sdw, ptp); do j = 0 to pt_size; if ptwa (j).df then do; add_ptw = (fixed (ptwa (j).add, 18) * 64); if (mem_address >= add_ptw) & (mem_address < add_ptw + 1024) then do; P_segno = divide (i, 2, 17); P_offset = (j * 1024) + word_no; P_indx = amu_info.process_idx; P_code = 0; return; end; end; end; end; /* if sdw is paged */ end; /* sdw loop */ /* now look at the ptw to see if it is valid */ if cme.ptwp = "0"b then do; /* no ptw pointer and not abs wired there for can not be in use */ P_code = amu_et_$free_core; return; end; ptp = addr (page_table_word); offset = fixed (cme.ptwp, 18); call amu_$do_translation (amu_info_ptr, sst_segno, ptp, offset, 1, code); if code ^= 0 then do; P_code = code; return; end; if ^(ptw.df) then do; /* page not in code */ P_code = amu_et_$free_core; return; end; /* now get the aste */ offset = fixed (cme.astep, 18); astep = addr (active_seg_table); aste_size = size (aste); call amu_$do_translation (amu_info_ptr, sst_segno, astep, offset, aste_size, code); if code ^= 0 then do; P_code = code; return; end; if aste.strp = "0"b then do; /* segment not active */ P_code = amu_et_$proc_not_dumped; call by_process_search; return; end; /* now get the str_seg data */ seg_name = "str_seg"; call amu_$slt_search_seg_num (hard_cur.sltp, hard_cur.sltntp, seg_name, str_segno, code); if code ^= 0 then do; P_code = code; return; end; offset = fixed (aste.strp, 18); str_size = size (str); strp = addr (seg_trailer); call amu_$do_translation (amu_info_ptr, str_segno, strp, offset, str_size, code); if code ^= 0 then do; P_code = code; return; end; /* now find the first process that this seg known */ do while (str.bp ^= "0"b); offset = fixed (str.bp, 18); call amu_$do_translation (amu_info_ptr, str_segno, strp, offset, str_size, code); if code ^= 0 then do; P_code = code; return; end; end; save_process_index = amu_info.process_idx; if amu_$return_val_per_process (amu_info_ptr, fixed (str.segno, 17)) then do; pds_dstep = amu_$definition_ptr (amu_info_ptr, "pds", "dstep", code); if code ^= 0 then do; P_code = code; return; end; save_process_index = amu_info.process_idx; next_str: loop_exit = "0"b; do temp_indx = 0 to hbound (fdump_process_table.array, 1) while (^loop_exit); call amu_$fdump_mpt_change_idx (amu_info_ptr, temp_indx); call amu_$do_translation_by_ptr (amu_info_ptr, pds_dstep, 1, addr (temp_dstep), code); if code ^= 0 then do; P_code = code; goto ERROR_EXIT; end; if temp_dstep = str.dstep /* found a procsee */ then loop_exit = "1"b; end; if (^loop_exit) & str.fp ^= "0"b then do; offset = fixed (str.fp, 18); call amu_$do_translation (amu_info_ptr, str_segno, strp, offset, str_size, code); if code ^= 0 then do; P_code = code; return; end; goto next_str; end; end; else loop_exit = "1"b; if ^(loop_exit) then P_code = amu_et_$proc_not_dumped; P_indx = amu_info.process_idx; P_segno = fixed (str.segno, 17); page_no = fixed (cme.ptwp, 18) - (fixed (cme.astep, 18) + aste_size); P_offset = word_no + (page_no * 1024); call amu_$fdump_mpt_change_idx (amu_info_ptr, save_process_index); return; ERROR_EXIT: P_code = code; call amu_$fdump_mpt_change_idx (amu_info_ptr, save_process_index); return; %page; /* We failed to find the address so we have to try to do so the hard way */ by_process_search: proc; dcl off18 fixed bin (18) aligned init (0); dcl last_seg fixed bin (35); dcl dsegp ptr; save_process_index = amu_info.process_idx; dumpptr = fdump_info.dump_seg_ptr (0); sstp = hardcore_cur.sstp; substr (unspec (off18), 19, 14) = substr (unspec (mem_address), 13, 14); do k = 0 to hbound (fdump_process_table.array, 1); call amu_$fdump_mpt_change_idx (amu_info_ptr, k); call amu_$do_translation_hunt_ptr (amu_info_ptr, pointer (baseptr (hardcore_info.dseg), 0), dsegp, code); if code ^= 0 then do; P_code = code; call amu_$fdump_mpt_change_idx (amu_info_ptr, save_process_index); return; end; fp_table_ptr = addr (fdump_process_table.array(k)); last_seg = fixed (dump.segs (fp_table.first_seg).length, 18) * 64; last_seg = divide (last_seg, 2, 17, 0) - 1; do i = 0 to last_seg; sdwp = addrel (dsegp, i * 2); if sdw.df then do; add_sdw = fixed (sdw.add, 24); bd_sdw = fixed (sdw.bound, 24) * 16; if sdw.unpaged then do; j = ((fixed (sdw.bound, 14) + 1) * 16) -1; if mem_address >= add_sdw & mem_address <= add_sdw + j then do; P_segno = divide (i, 2, 17); P_offset = mem_address -add_sdw; P_indx = amu_info.process_idx; P_paged = "0"b; P_code = 0; goto RET; end; else go to next_lap; end; else do; ptp = addrel (sstp, add_sdw - fixed (sst.ptwbase, 18)); pt_size = divide (bd_sdw, 1024, 18); astep = addrel (ptp, - (sst.astsize)); do j = 0 to fixed (aste.csl, 9); if ^ptw.df then go to pt_lap; if fixed (ptw.add, 18) = off18 then do; P_segno = i; P_offset = j * 1024 + mod (mem_address, 1024); P_indx = amu_info.process_idx; P_code = 0; goto RET; end; pt_lap: ptp = addrel (ptp, 1); end; end; end; next_lap: end; end; RET: call amu_$fdump_mpt_change_idx (amu_info_ptr, save_process_index); return; end by_process_search; %page; get_ptp: proc(add_sdw, ptp); /* Parameters */ dcl add_sdw fixed bin(24); dcl ptp ptr; /* This routine determines the page table pointer . add_sdw the contents of a sdw address (input), ptp page table pointer (output), */ dcl relative_offset fixed bin(26); dcl sdw_add fixed bin(26); dcl sst_ptr ptr; sst_ptr = hardcore_cur.sstp; sdw_add = fixed (add_sdw, 26); /* want fixed bin(26) */ if upt_ptr = null() then do; relative_offset = add_sdw - sst_base; ptp = addrel(sst_ptr, relative_offset); end; else if (add_sdw > upt.upt_absloc & add_sdw < upt.upt_last_loc) then do; /* found in unpaged_page_tables */ relative_offset = sdw_add - upt.upt_absloc; ptp = addrel(upt_ptr, relative_offset); end; else if (add_sdw > upt.iupt_absloc & add_sdw < upt.iupt_last_loc) then do; /* found in int_unpaged_page_tables */ relative_offset = sdw_add - upt.iupt_absloc; ptp = addrel(upt_ptr, relative_offset); end; else do; /* found in sst_seg */ relative_offset = sdw_add - upt.sst_absloc; ptp = addrel(sst_ptr, relative_offset); end; end get_ptp; %page;%include amu_fdump_info; %page;%include amu_hardcore_info; %page;%include amu_info; %page;%include aste; %page;%include bos_dump; %page;%include cmp; %page;%include ptw; %page;%include scs; %page;%include sdw; %page;%include sst; %page;%include str; %page;%include unpaged_page_tables; end azm_dump_mem_;  azm_find_mem_box_.pl1 11/19/84 1143.5rew 11/15/84 1440.1 23211 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ azm_find_mem_box_: proc (P_amu_info_ptr, P_address, P_segno, P_offset, P_code); /* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */ dcl P_amu_info_ptr ptr; dcl P_address fixed bin (35); dcl P_code fixed bin (35); dcl P_segno fixed bin; dcl P_offset fixed bin (18); dcl code fixed bin (35); dcl address fixed bin (35); dcl page_addr fixed bin; dcl (i, offset) fixed bin (17); dcl control_data_ptr ptr; dcl range fixed bin (18); dcl temp_ptr ptr; dcl brief_sw bit (1) init ("0"b); dcl 1 controller_data (0:7) aligned like scs$controller_data; dcl amu_$definition_ptr entry (ptr, char (*), char (*), fixed bin (35)) returns (ptr); dcl amu_$do_translation_by_ptr entry (ptr, ptr, fixed bin (18), ptr, fixed bin (35)); dcl amu_$get_name entry (ptr, ptr) returns (char (*)); dcl ioa_ entry () options (variable); dcl (addr, addrel, baseptr, divide, substr, size) builtin; %page; go to common; azm_find_mem_box_$bf: entry (P_amu_info_ptr, P_address, P_segno, P_offset, P_code); brief_sw = "1"b; common: amu_info_ptr = P_amu_info_ptr; address = P_address; page_addr = divide (address, 1024, 17, 0); control_data_ptr = amu_$definition_ptr (amu_info_ptr, "scs", "controller_data", code); if code ^= 0 then do; P_code = code; return; end; range = size (controller_data); call amu_$do_translation_by_ptr (amu_info_ptr, control_data_ptr, range, addr (controller_data), code); if code ^= 0 then do; P_code = code; return; end; do i = 0 to 7; if (page_addr >= controller_data (i).base) then do; if page_addr < (controller_data (i).base + controller_data (i).size) then do; temp_ptr = addrel (baseptr (P_segno), P_offset); offset = (address - (controller_data (i).base * 1024)); if ^brief_sw then call ioa_ ("^a (^p):", amu_$get_name (amu_info_ptr, temp_ptr), temp_ptr); call ioa_ ("Absolute Addr ^o (Word ^o in Mem ^a).", address, offset, substr ("abcdefgh", i + 1, 1)); P_code = 0; return; end; end; end; call ioa_ ("Cannot find address ^o.", address); P_code = 0; return; %page; %include amu_info; %page; %include scs; end azm_find_mem_box_;  azm_pdir_rq_table_.alm 11/05/86 1349.4r w 11/04/86 1039.3 28548 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1983 * " * * " *********************************************************** " AZM_PDIR_RQ_TABLE_ " " Request definitions for analyze_multics select_deadproc request. " " Initial coding: 08/14/84 by B. Braun " " name azm_pdir_rq_table_ include ssu_request_macros begin_table azm_pdir_rq_table_ request add_request_table,azm_requests_2_$add_request_table, (arqt), (Adds a request table for use.), flags.allow_command request apply,azm_requests_1_$extract_seg,(ap), (Apply command to selected segment.), flags.allow_command request display,azm_requests_1_$display,(d), (Displays selected portions of segments or real memory.), flags.allow_both request frame,azm_stack_requests_$frame, (fr), (Displays information from a single stack frame.), flags.unimplemented+flags.dont_summarize+flags.dont_list request history_regs,azm_requests_1_$history_regs,(hregs), (Display CPU history registers.), flags.allow_command request list_dumps,azm_address_space_$list_dumps, (lsd), (Lists dumps via the dumps search paths.), flags.allow_command request machine_conditions,azm_requests_1_$mc,(mc), (Print machine condition frame from .), flags.allow_command request page_trace,azm_pds_trace_$azm_pds_trace_,(pgt), (Print system trace table for process.), flags.allow_command request quit,azm_requests_2_$quit,(q), (Leave analyze_multics.), flags.allow_command request replace,azm_requests_2_$replace,(rp), (Replace translation of segment number with path.), flags.allow_command request sdw,azm_requests_1_$sdw, (), (List SDWs in DSEG.), flags.allow_command request select_deadproc,azm_address_space_$deadproc,(sldp), (Switch to looking at a dead process directory.), flags.allow_both request select_dump,azm_address_space_$erf,(sld), (Switch to examining a specific FDUMP.), flags.allow_command request search,azm_requests_2_$search,(srh), (Search a segment for an octal pattern on a word boundary.), flags.allow_both request segment_name,azm_requests_2_$name,(name), (Print segment name given number.), flags.allow_both request segment_number,azm_requests_2_$number,(number), (Print segment number given name.), flags.allow_both request set,azm_requests_2_$set, (), (Set a temporary pointer.), flags.allow_command request stack,azm_stack_requests_$stack,(sk), (Trace the requested stack.), flags.allow_command request value,azm_requests_2_$value,(v), (Display a temporary pointer.), flags.allow_command request .,azm_requests_2_$self_identify,(), (), flags.dont_summarize+flags.dont_list+flags.allow_command request nothing,ssu_$just_return,(nt), (), flags.dont_summarize+flags.dont_list+flags.allow_both multics_request index_set, (), (), (), flags.dont_summarize+flags.dont_list+flags.allow_both end_table azm_pdir_rq_table_ end  azm_pds_trace_.pl1 11/19/84 1143.5rew 11/15/84 1440.2 64251 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ azm_pds_trace_: proc (P_sci_ptr, P_azm_info_ptr); /* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */ dcl ( P_sci_ptr pointer, P_azm_info_ptr pointer ) parameter; dcl sci_ptr pointer; dcl amu_$do_translation entry (ptr, fixed bin, ptr, fixed bin (18), fixed bin (18), fixed bin (35)), amu_$definition_ptr entry (ptr, char (*), char (*), fixed bin (35)) returns (ptr), amu_$get_name_no_comp entry (ptr, ptr) returns (char (*)), amu_$get_name entry (ptr, ptr) returns (char (*)), ssu_$abort_line entry () options (variable), ( ioa_, ioa_$nnl ) entry () options (variable), error_table_$noarg fixed bin (35) ext static, error_table_$bad_arg fixed bin(35) ext static, cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)), ssu_$arg_count entry (pointer, fixed bin, bit (1) aligned), ssu_$arg_ptr entry (pointer, fixed bin, pointer, fixed bin (21)), ssu_$get_temp_segment entry (ptr, char(*), ptr), ssu_$release_temp_segment entry (ptr, ptr); dcl al fixed bin (21), arg char (al) based (ap), ap ptr, (argno, nargs) fixed bin, code fixed bin (35); dcl af_sw bit (1) aligned; dcl (number, entry_number, index) fixed bin; dcl (by_ptr, ref_ptr, temp_link_ptr, trace_buf_ptr) ptr; dcl cond_type char (4) based (trace_ptr); dcl 1 trace_buf like trace based (trace_buf_ptr); dcl link_ptr ptr unal based (trace_ptr); dcl entry_type (0:12) char (20) init ("page_fault_type", "illegal entry type", "seg fault start", "seg fault end", "linkage fault start", "linkage fault end", "boundfault start", "boundfault end", "signaller type", "restart fault type", "reschedule type", "marker type", "interrupt type") static options (constant); dcl (addr, baseno, baseptr, bin, binary, fixed, null, pointer, rel, rtrim, size, substr, unspec) builtin; dcl cleanup condition; %page; sci_ptr = P_sci_ptr; azm_info_ptr = P_azm_info_ptr; amu_info_ptr = azm_info.aip; trace_buf_ptr = null(); on condition(cleanup) begin; if trace_buf_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, trace_buf_ptr); end; call ssu_$arg_count (sci_ptr, nargs, af_sw); if nargs = 0 then number = 15; do argno = 1 to nargs; call ssu_$arg_ptr (sci_ptr, argno, ap, al); if arg = "-all" | arg = "-a" then number = 0; else if arg = "-lt" | arg = "-last" then do; if argno + 1 > nargs then call ssu_$abort_line (sci_ptr, error_table_$noarg, "Number expected after ^a", arg); argno = argno + 1; call ssu_$arg_ptr (sci_ptr, argno, ap, al); number = cv_dec_check_ (arg, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, " ""^a"" is not decimal.", arg); end; else /* unrecognized arg */ call ssu_$abort_line (sci_ptr, error_table_$bad_arg, ""); end; call ssu_$get_temp_segment (sci_ptr, "azm-pgt", trace_buf_ptr); call get_page_trace_azm (trace_buf_ptr); if number = 0 then number = trace_buf.last_available; call select_entry; call ssu_$release_temp_segment (sci_ptr, trace_buf_ptr); return; %page; select_entry: proc; entry_number = 0; do index = (trace_buf.next_free - 1) by -1 to 1 while (number > 0), trace_buf.last_available - 1 by -1 to trace_buf.next_free while (number > 0); trace_ptr = addr (trace_buf.data (index)); call print_entry; number = number - 1; end; end select_entry; %page; print_entry: proc; dcl e_type fixed bin; dcl seg_n fixed bin; dcl path char (168); dcl page_n fixed bin; entry_number = entry_number + 1; e_type = fixed (page_trace_entry.type, 6); call ioa_$nnl ("^d^2x", entry_number); if e_type = 0 then do; seg_n = binary (page_trace_entry.segment_number, 15); page_n = binary (page_trace_entry.page_number, 12); path = amu_$get_name_no_comp (amu_info_ptr, baseptr (seg_n)); call ioa_ ("^20a^x^5o^x^4o^5x^1o^2x^a", entry_type (e_type), seg_n, page_n, binary (page_trace_entry.ring, 3), path); return; end; if e_type = 8 | e_type = 11 then do; call ioa_ ("^20a^5x^4a", entry_type (e_type), cond_type); return; end; if e_type = 9 | e_type = 10 then do; call ioa_ ("^20a", entry_type (e_type)); return; end; if e_type = 2 | e_type = 3 | e_type = 6 | e_type = 7 then do; seg_n = binary (page_trace_entry.segment_number, 15); path = amu_$get_name_no_comp (amu_info_ptr, baseptr (seg_n)); call ioa_ ("^20a^26tsegno^5o^2x^a", entry_type (e_type), seg_n, path); return; end; if e_type = 5 then do; if page_trace_entry.pad = "0"b then do; call ioa_ ("link_make_end"); return; end; else do; temp_link_ptr = link_ptr; path = amu_$get_name (amu_info_ptr, temp_link_ptr); call ioa_ ("^20a^x^12p^2x^a", entry_type (e_type), temp_link_ptr, path); return; end; end; if e_type = 15 then do; by_ptr = pointer (baseptr (bin (extended_page_trace_entry.psr_segno, 12)), fixed (extended_page_trace_entry.psr_offset, 18)); call ioa_ ("page_fault by^18t^12p^2x^a", by_ptr, rtrim (amu_$get_name (amu_info_ptr, by_ptr))); ref_ptr = baseptr (bin (extended_page_trace_entry.tsr_segno_1 || extended_page_trace_entry.tsr_segno_2, 12)); call ioa_ ("^6xreferencing ^4o page ^o^32t^a", baseno (ref_ptr), extended_page_trace_entry.tsr_pageno, rtrim (amu_$get_name_no_comp (amu_info_ptr, ref_ptr))); return; end; if e_type = 4 then do; if page_trace_entry.pad = "0"b then do; call ioa_ ("link_make_start"); return; end; else do; temp_link_ptr = link_ptr; path = amu_$get_name (amu_info_ptr, temp_link_ptr); call ioa_ ("^20a^x^12p^2x^a", entry_type (e_type), temp_link_ptr, path); return; end; end; call ioa_$nnl ("^20a ^12.3b ^12.3b", entry_type (e_type), substr (unspec (page_trace_entry), 1, 36), substr (unspec (page_trace_entry), 37, 36)); call ioa_ (" "); end print_entry; %page; get_page_trace_azm: proc (a_dp); dcl a_dp ptr; dcl seg fixed bin; dcl (word, number) fixed bin (18); dcl temp_ptr ptr; dcl code fixed bin (35); dcl data_buf_ptr ptr; temp_ptr = amu_$definition_ptr (amu_info_ptr, "pds", "trace", code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "page_trace."); seg = fixed (baseno (temp_ptr), 17); word = fixed (rel (temp_ptr), 18); number = size (trace_buf); data_buf_ptr = a_dp; call amu_$do_translation (amu_info_ptr, seg, data_buf_ptr, word, number, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "page_trace."); return; end get_page_trace_azm; %page; %include bos_dump; %page; %include amu_fdump_info; %page; %include amu_info; %page; %include azm_info; %page; %include sys_trace; %page; end azm_pds_trace_;  azm_request_table_.alm 11/05/86 1349.4r w 11/04/86 1039.3 54891 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1983 * " * * " *********************************************************** " AZM_REQUEST_TABLE_ " " Request definitions for analyze_multics subsystem. " " Initial coding: 09/07/80 W. Olin Sibert " " Modified: 06/21/83 B.Braun " to add/modify requests per MTB624 revision 1. " " Modified: 08/14/84 B.Braun " to add select_deadproc request per MTB665. " name azm_request_table_ include ssu_request_macros begin_table azm_request_table_ request absolute_address,azm_requests_2_$absolute_address, (absadr), (Prints the absolute address of .), flags.allow_both request add_request_table,azm_requests_2_$add_request_table, (arqt), (Adds a request table for use.), flags.allow_command request apply,azm_requests_1_$extract_seg,(ap), (Apply command to selected segment.), flags.allow_command request apte,azm_requests_1_$apte, (), (Print apte info.), flags.allow_both request associative_memory,azm_requests_2_$associative_memory, (am), (Display associative memory.), flags.allow_command request aste,azm_requests_1_$aste, (), (Print aste for .), flags.allow_command request clock,azm_requests_2_$clock, (), (Interprets a Multics clock.), flags.unimplemented+flags.dont_summarize+flags.dont_list request configuration_deck,azm_requests_1_$config_deck,(cd), (Print the config deck found in the FDUMP.), flags.allow_command request delete_dump,azm_address_space_$delete_dump, (dld), (Deletes a dump given the ERF name.), flags.unimplemented+flags.dont_summarize+flags.dont_list request delete_request_table,azm_requests_2_$delete_request_table, (drqt), (Deletes a request table from the request table list.), flags.unimplemented+flags.dont_summarize+flags.dont_list request display,azm_requests_1_$display,(d), (Displays selected portions of segments or real memory.), flags.allow_both request display_absolute,azm_requests_1_$display_abs, (da), (Displays what's at a given absolute memory address.), flags.allow_both request error_code,azm_requests_2_$error_code,(err), (Display a standard error_code.), flags.unimplemented+flags.dont_summarize+flags.dont_list request events,azm_requests_3_$events,(ev), (Display dump events.), flags.allow_command request fdump_components,azm_address_space_$fdump_components, (), (Prints absolute pathnames of a FDUMP component.), flags.unimplemented+flags.dont_summarize+flags.dont_list request frame,azm_stack_requests_$frame, (fr), (Displays information from a single stack frame.), flags.unimplemented+flags.dont_summarize+flags.dont_list request history_regs,azm_requests_1_$history_regs,(hregs), (Display CPU history registers.), flags.allow_command request list_dumps,azm_address_space_$list_dumps, (lsd), (Lists dumps via the dumps search paths.), flags.allow_command request list_processes,azm_requests_1_$list_proc, (lsp), (Lists all processes in the current dump.), flags.allow_both request list_request_table,azm_requests_2_$list_request_table, (lrqt), (Lists all request tables in the request table list.), flags.unimplemented+flags.dont_summarize+flags.dont_list request machine_conditions,azm_requests_1_$mc,(mc), (Print machine condition frame from .), flags.allow_command request page_trace,azm_pds_trace_$azm_pds_trace_,(pgt), (Print system trace table for process.), flags.allow_command request quit,azm_requests_2_$quit,(q), (Leave analyze_multics.), flags.allow_command request replace,azm_requests_2_$replace,(rp), (Replace translation of segment number with path.), flags.allow_command request scus,azm_requests_2_$scus,(), (Print the memory configuration at dump time.), flags.allow_command request sdw,azm_requests_1_$sdw, (), (List SDWs in DSEG.), flags.allow_command request select_deadproc,azm_address_space_$deadproc,(sldp), (Switch to looking at a dead process directory.), flags.allow_both request select_dump,azm_address_space_$erf,(sld), (Switch to examining a specific FDUMP.), flags.allow_command request select_process,azm_requests_1_$select_proc,(slp), (Selects a process from the FDUMP.), flags.allow_both request search,azm_requests_2_$search,(srh), (Search a segment for an octal pattern on a word boundary.), flags.allow_both request segment_name,azm_requests_2_$name,(name), (Print segment name given number.), flags.allow_both request segment_number,azm_requests_2_$number,(number), (Print segment number given name.), flags.allow_both request set,azm_requests_2_$set, (), (Set a temporary pointer.), flags.allow_command request syserr_log,azm_requests_3_$syserr_log,(slog), (Print message(s) in syserr_log.), flags.allow_command request stack,azm_stack_requests_$stack,(sk), (Trace the requested stack.), flags.allow_command request traffic_control_queue,azm_requests_3_$tcq,(tcq), (Print the traffic controller queue.), flags.allow_both request value,azm_requests_2_$value,(v), (Display a temporary pointer.), flags.allow_command request verify_associative_memory, azm_requests_2_$verify_am,(vfam), (Verify the associative memories in bos cpu.), flags.allow_both request why,azm_stack_requests_$why,(), (Try to find the failing process.), flags.allow_command request .,azm_requests_2_$self_identify,(), (), flags.dont_summarize+flags.dont_list+flags.allow_command request nothing,ssu_$just_return,(nt), (), flags.dont_summarize+flags.dont_list+flags.allow_both multics_request index_set, (), (), (), flags.dont_summarize+flags.dont_list+flags.allow_both end_table azm_request_table_ end  azm_requests_1_.pl1 07/20/88 1255.0r w 07/19/88 1533.2 864072 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-01-14,Parisek), approve(87-07-09,MCR7746), audit(87-07-17,Fawcett), install(87-07-28,MR12.1-1049): Check online libraries for segment when "display" cannot locate it in the translation_table (when instruction format is not wanted). Print message stating seg was not found in fdump, then display data from online copy. (phx19329). 2) change(87-01-16,Parisek), approve(87-07-09,MCR7746), audit(87-07-17,Fawcett), install(87-07-28,MR12.1-1049): Bypass call to amu_$fdump_mpt_revert_idx if segment was previously replaced by another segment (via "replace" request) so the subsequent call to amu_$get_name_ will return the replaced segment path. 3) change(87-02-24,Parisek), approve(87-07-09,MCR7746), audit(87-07-17,Fawcett), install(87-07-28,MR12.1-1049): If structure name given with display -as is "dte" then interpret it as ioi_dte as defined in the structure_names info segment. END HISTORY COMMENTS */ azm_requests_1_: proc (); return; /* not an entrypoint */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */ /* Assorted requests for analyze_multics. */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* 0) Created: 06/25/83 by B. Braun to divide up old azm_misc_requests_. This module */ /* contains the requests apte, aste, machine_conditions, list_processes, select_process, */ /* history_regs, apply, display, display_absolute, sdw, configuration_deck. */ /* */ /* Modified 19 Jan 84 by BLB changes to machine_conditions so -prds and -pds accept long */ /* names (phx16722), interprets a virt-addr better (phx16723) drop EIS data from default */ /* mc output (phx16724), fix mc -dump so doesn't fault thru invalid ptr. */ /* Modified 19 Jan 84 by BLB changes to list_processes so -count in AF works (phx16580) */ /* Modified 03 Oct 84 by BLB to fix "mc -anything -pds". */ /* Modified 18 Oct 84 by BLB to fix aste to work with unpaged_page_tables. */ /* Modified 08 Nov 84 by BLB to fix display AF error message. */ /* Modified 21 Jan 85 by BLB to fix sdw request, to print all sdws, not just ones where */ /* the directed fault bit is on. */ /* Modified March 86 by P. Leatherman to fix core map entry offset. */ /* Modified March 86 by P. Leatherman to fix pointers arg to the mc request. */ /* Modified March 86 by P. Leatherman to have the display command say if the segment */ /* isn't in the dump and then search hardcore for it. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl ( P_sci_ptr pointer, P_azm_info_ptr pointer ) parameter; /* Automatic */ dcl PTWF char (32); dcl af_sw bit (1) aligned; dcl arg_position fixed bin; dcl all_sw bit (1); dcl axp ptr init (null); dcl apte_array_ptr ptr; dcl apte_array_index fixed bin; dcl apte_offset fixed bin (18); dcl argl fixed bin (21); dcl argno fixed bin; dcl argp pointer; dcl axstring char (9) init (""); dcl bd_sdw fixed bin (24); dcl bitcount fixed bin(35); dcl block fixed bin; dcl brief_sw bit (1) init ("0"b); dcl cleanup condition; dcl cdevadd char (16); dcl coremaptr ptr; dcl code fixed bin (35); dcl command_arg fixed bin; dcl cond_frame bit (1); dcl config_arg_str char (256) var; dcl core_add fixed (18); dcl configp ptr init (null); dcl copy_ptr pointer; dcl cpu_name char (1); dcl cpu_sw bit(1); dcl cur_sw bit(1); dcl cur_erf bit (1) init ("0"b); dcl ct_sw bit(1); dcl data_buf_ptr ptr; dcl dbr fixed bin (24); dcl dbr_sw bit(1); dcl del_cur_erf bit (1) init ("0"b); dcl del_erf bit (1) init ("0"b); dcl devadd bit (22); dcl devadd_nulled_flag bit (1) defined (devadd); dcl devadd_record_no bit (18) defined (devadd); dcl devadd_add_type bit (4) defined (devadd) pos (19); dcl dir_name char (168); dcl dir_name_lth fixed bin; dcl dir_sw bit (1) init ("0"b); dcl display_ptr pointer; dcl display_size fixed bin (18); dcl dsegp ptr init (null); dcl erfs_found bit (1) init ("0"b); dcl entryname char (32); dcl expand_ptr_sw bit (1) init ("0"b); dcl expand_sw bit (1) init ("0"b); /* "1"b = expand syserr binary data */ dcl interpreted_hregs bit (1); dcl fdevadd fixed (18); dcl first fixed bin (18); dcl first_segno fixed bin; dcl first1 fixed bin (18); dcl first_erf bit (1) init ("0"b); dcl first_ptr_arg fixed bin; dcl first_value_set bit (1) init ("0"b); dcl forward_search bit (1) init ("0"b); dcl frame_entry bit (1) init ("0"b); dcl 1 hard_ptr_space like hardcore_cur; dcl header_sw bit(1); dcl hdr_printed bit (1) init ("0"b); dcl hold_index fixed bin; dcl hr_switches bit (5); dcl hregs_from_dump bit (1); dcl hregs_from_pds bit (1); dcl hregs_fm_ptrval bit (1); dcl ignore fixed bin; dcl index_changed bit (1); dcl is_wired bit (1); dcl is_paged bit (1); dcl (i, k) fixed bin; /* for iterations */ dcl last fixed bin init (0); dcl last_erf bit (1) init ("0"b); dcl last_ptw bit (36); dcl last_segno fixed bin; dcl list_erfs bit (1) init ("0"b); dcl list_state(0:6) bit(1); dcl ll fixed bin init (0); dcl ln fixed bin init (0); dcl long_sw bit (1); dcl match_names (10) char (32) varying; dcl match_str char (256) var init (""); /* the syserr string to match on */ dcl mc_from_ptrval bit (1); dcl 1 mc_area like mc; dcl mc_arg bit (36) aligned; /* place in stack to keep the arg bits passed to azm_display_mc_ */ dcl mcp_fim_sw bit (1); dcl mcp_pgflt_sw bit (1); dcl mcp_sig_sw bit (1); dcl mcpr_fim_sw bit (1); dcl mcpr_int_sw bit (1); dcl mcpr_systroub_sw bit (1); dcl mem_addr fixed bin (24); dcl mem_dump bit (1); %page; dcl 1 modes_sw aligned, 2 char_sw bit (1) unal, 2 inst_sw bit (1) unal, 2 bcd_sw bit (1) unal, 2 ptr_sw bit (1) unal, 2 pptr_sw bit (1) unal, 2 bit4_sw bit (1) unal, 2 ebcdic8_sw bit (1) unal, 2 ebcdic9_sw bit (1) unal; dcl mem_tag fixed bin; dcl n_match_names fixed bin; dcl n_subscripts fixed bin; dcl nargs fixed bin; dcl new_range fixed bin (21); dcl next_erf bit (1) init ("0"b); dcl no_aste_tr_info bit(1); dcl offset fixed bin (18); dcl only_au bit (1); dcl only_cu bit (1); dcl only_du bit (1); dcl only_ou bit (1); dcl octal_sw bit(1); dcl outername char (32); dcl pidbit bit(36); dcl pid fixed bin(36); dcl pcd_args char (256); dcl pcd_argsp ptr; dcl pcd_args_len fixed bin (21); dcl pds_sw bit (1); dcl prev_erf bit (1) init ("0"b); dcl prds_sw bit (1); dcl print_all_trans bit (1) init ("0"b); dcl proc_ptr pointer; dcl procl fixed bin(21); dcl proc_sw bit(1); dcl process_idx fixed bin; dcl pts fixed bin (24); dcl pvtx_name char (16) varying; dcl range fixed bin (18); dcl range1 fixed bin (18); dcl range_value_set bit (1) init ("0"b); dcl raw_syserr_data bit (1) init ("0"b); /* "1"b = print it in octal */ dcl real_address fixed bin (35); dcl reason char (80) var; dcl repeat_ bit (1); dcl ret_str char (168) var init (""); dcl rv_lth fixed bin (21); dcl rv_ptr ptr; dcl sci_ptr pointer; /* assorted info pointers */ dcl sdw_address fixed bin(26); dcl segln fixed bin (35) init (0); dcl segno fixed bin; dcl segno1 fixed bin; dcl sigstp ptr; dcl slog_code fixed bin init (3); /* the syserr_code, default to =< 3 */ dcl sptp ptr; dcl start_configp ptr init (null); dcl str char (16); dcl struct_name char (256) varying; dcl struct_sw bit (1) init ("0"b); dcl subscripts (2, 16) fixed bin (24); dcl symbol_ptr ptr; dcl t_pr_name char (4); dcl temp_name char (32); dcl temp_num fixed bin; dcl temp_ptr ptr; dcl temp_ptr1 ptr; dcl temp_range fixed bin (18); dcl temp_str char (24) var init (""); dcl threaded_hregs bit (1); dcl tally_states (0:6) fixed bin; dcl totals_only bit(1); dcl trailer_sw bit (1); dcl unsubscripted_name char (256); dcl vs char (99) varying; dcl why_erf bit (1) init ("0"b); %page; /* Based */ dcl 1 apte_array (apte_array_index) based (apte_array_ptr), 2 ptr ptr, 2 off fixed bin (18), 2 index fixed bin; dcl arg char (argl) based (argp); dcl proc_arg char (procl) based (proc_ptr); dcl pt_word fixed based (ptp); dcl ret_ptr ptr based (data_buf_ptr); dcl rv_str char (rv_lth) varying based (rv_ptr); dcl RS (range) bit (36) based (data_buf_ptr); dcl RSP (range) ptr aligned based (data_buf_ptr); dcl RSPP (range) ptr unal based (data_buf_ptr); dcl 1 sig_stack like signaller_stack based (sigstp); /* Constants */ dcl CPU_NAME char (8) init ("abcdefgh") internal static options (constant); dcl (RUN init(1), RDY init(2), WAIT init(3), BLK init(4), STP init(5), PTL init(6)) fixed bin int static options (constant); dcl process_st (0:6) char (9) varying int static options (constant) init ("empty", "running", "ready", "waiting", "blocked", "stopped", "ptlocking"); /* Builtins */ dcl (addr, addrel, baseno, baseptr, char, convert, divide, fixed, hbound, index, lbound, length, ltrim, mod, null, pointer, rel, rtrim, size, substr, unspec) builtin; /* Conditions */ %page; /* External Entries */ dcl adjust_bit_count_ entry (char(168), char(32), bit(1) aligned, fixed bin(35), fixed bin(35)); dcl amu_$definition_ptr entry (ptr, char (*), char (*), fixed bin (35)) returns (ptr); dcl amu_$definition_set_from entry (ptr, char (*), ptr, fixed bin (35)); dcl amu_$definition_get_prn entry (ptr, char (*), ptr, fixed bin (35)); dcl amu_$definition_set_prn entry (ptr, char (*), fixed bin, fixed bin (18), fixed bin (35)); dcl amu_$do_translation entry (ptr, fixed bin, ptr, fixed bin (18), fixed bin (18), fixed bin (35)); dcl amu_$do_translation_hunt_ptr entry (ptr, ptr, ptr, fixed bin (35)); dcl amu_$do_translation_hunt entry (ptr, fixed bin, ptr, fixed bin (18), fixed bin (18), fixed bin (35)); dcl amu_$error_for_caller entry () options (variable); dcl amu_$fdump_mpt_fill_proc_table entry (ptr, fixed bin (24), fixed bin, char (1), bit(1), fixed bin (35)); dcl amu_$fdump_mpt_current_process entry (ptr); dcl amu_$fdump_mpt_current_process_af entry (ptr, ptr, fixed bin (21)); dcl amu_$fdump_mpt_temp_change_idx entry (ptr, fixed bin); dcl amu_$fdump_mpt_change_idx entry (ptr, fixed bin); dcl amu_$fdump_mpt_revert_idx entry (ptr); dcl amu_$fdump_translate_to_temp_seg entry (ptr, ptr, ptr, fixed bin (35)); dcl amu_$get_name_no_comp entry (ptr, ptr) returns (char (*)); dcl amu_$get_name entry (ptr, ptr) returns (char (*)); dcl amu_$get_segno_from_name entry (ptr, ptr, char(*), fixed bin, fixed bin(35)); dcl amu_$get_va_args entry (ptr, ptr, ptr, fixed bin, ptr); dcl amu_$get_va_args_given_start entry (ptr, ptr, ptr, fixed bin, fixed bin, ptr); dcl amu_$hardcore_info_set_cur_ptrs entry (ptr, ptr); dcl amu_$print_char_dump entry (ptr, fixed bin (18), fixed bin (18)); dcl amu_$print_char_dump_af entry (ptr, fixed bin (18), fixed bin (18), ptr, fixed bin(21)); dcl amu_$print_apte entry (ptr, ptr, fixed bin (18), fixed bin); dcl amu_$print_dump_oct entry (ptr, fixed bin (18), fixed bin (18)); dcl amu_$print_dump_pptr entry (ptr, fixed bin (18), fixed bin (18)); dcl amu_$print_dump_pptr_exp entry (ptr, ptr, fixed bin (18), fixed bin (18)); dcl amu_$print_dump_ptr entry (ptr, fixed bin (18), fixed bin (18)); dcl amu_$print_dump_ptr_exp entry (ptr, ptr, fixed bin (18), fixed bin (18)); dcl amu_$print_inst_dump entry (ptr, fixed bin (18), fixed bin (18)); dcl amu_$return_val_per_process entry (ptr, fixed bin) returns (bit (1)); dcl amu_$slt_search_seg_ptr entry (ptr, ptr, char (32), ptr, fixed bin (35)); dcl amu_$tc_data_get_apt_entry entry (ptr, fixed bin, bit(36), fixed bin(18), ptr, fixed bin); dcl amu_$tc_data_get_dbr entry (ptr, fixed bin (18), fixed bin (24)); dcl amu_$translate_get entry (ptr, fixed bin, ptr, fixed bin (35)); dcl amu_$translate_force_add entry (ptr, ptr, fixed bin, fixed bin (35)); dcl display_data_$for_azm entry (pointer, bit (*) aligned, (*) char (*) varying, fixed bin, pointer, pointer, fixed bin (18), pointer, pointer, (2, *) fixed bin (24), fixed bin, fixed bin (35)); dcl azm_display_mc_ entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl azm_dump_mem_ entry (ptr, fixed bin (24), fixed bin, fixed bin, fixed bin (18), fixed bin, bit (1), bit (1), fixed bin (35)); dcl azm_find_mem_box_$bf entry (ptr, fixed bin (35), fixed bin, fixed bin (18), fixed bin (35)); dcl hran_$bos_no_thread entry (ptr, ptr, bit (5)); dcl hran_$hran_bos entry (ptr, ptr, bit (1)); dcl hran_$hranl entry (ptr, ptr, bit (1)); dcl hran_$no_thread entry (ptr, ptr, bit (5)); dcl azm_str_util_ entry (ptr, bit (18), fixed bin (35)); dcl cu_$cp entry (ptr, fixed bin (21), fixed bin (35)); dcl (cv_dec_check_, cv_oct_check_) entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl dump_segment_ entry (ptr, ptr, fixed bin, fixed bin(18), fixed bin(18), bit(*)); dcl dump_segment_$string entry (ptr, fixed bin(21), ptr, fixed bin, fixed bin(18), fixed bin(18), bit(*)); dcl get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl ( ioa_, ioa_$nnl, ioa_$rsnnl ) entry options (variable); dcl iox_$user_output ptr ext static; dcl ssu_$abort_line entry options (variable); dcl ssu_$apply_request_util entry (ptr, fixed bin, ptr, fixed bin (21), fixed bin (21)); dcl ssu_$arg_count entry (pointer, fixed bin, bit (1) aligned); dcl ssu_$arg_ptr entry (pointer, fixed bin, pointer, fixed bin (21)); dcl ssu_$get_temp_segment entry (ptr, char(*), ptr); dcl ssu_$print_message entry options (variable); dcl ssu_$release_temp_segment entry (ptr, ptr); dcl ssu_$return_arg entry (ptr, fixed bin, bit (1) aligned, ptr, fixed bin (21)); dcl ssu_$get_subsystem_and_request_name entry (ptr) returns(char(72) var); dcl structure_ref_$parse entry (char (*), char (*), char (*), (2, *) fixed bin (24), fixed bin, (*) char (*) varying, fixed bin, fixed bin (35)); dcl structure_find_$search entry (char (*), pointer, fixed bin (35)); dcl sys_info$max_seg_size fixed bin (35) ext static; /* error codes */ dcl amu_et_$big_idx fixed bin (35) external static; dcl amu_et_$dbr_not_found fixed bin (35) external static; dcl amu_et_$free_core fixed bin (35) external static; dcl amu_et_$invalid_segno fixed bin (35) ext static; dcl amu_et_$neg_range fixed bin (35) ext static; dcl amu_et_$no_translation fixed bin (35) ext static; dcl amu_et_$not_implemented fixed bin (35) ext static; dcl amu_et_$not_stack_seg fixed bin (35) ext static; dcl amu_et_$proc_not_dumped fixed bin (35) ext static; dcl amu_et_$seg_not_dumped fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) external static; dcl error_table_$noarg fixed bin (35) external static; dcl error_table_$bad_arg fixed bin (35) external static; dcl error_table_$inconsistent fixed bin (35) external static; dcl error_table_$too_many_args fixed bin (35) external static; %page; azm_requests_1_$apte: entry (P_sci_ptr, P_azm_info_ptr); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); apte_array_ptr = null(); on cleanup begin; if apte_array_ptr ^= null () then call ssu_$release_temp_segment (sci_ptr, apte_array_ptr); end; call process_common_args(); call ssu_$get_temp_segment (sci_ptr, "azm-apt", apte_array_ptr); if ^proc_sw & ^cur_sw then do; do i = 1 to hbound(list_state, 1); apte_array_index = 0; if list_state(i) then do; call amu_$tc_data_get_apt_entry (amu_info_ptr, i, "0"b, -1, apte_array_ptr, apte_array_index); tally_states(i) = apte_array_index; if apte_array_index = 0 & ^(all_sw | ct_sw) then call ioa_("No aptes in the ^a state.", process_st(i)); do k = 1 to apte_array_index; if ^totals_only then call amu_$print_apte (amu_info_ptr, apte_array (k).ptr, apte_array (k).off, apte_array (k).index); end; end; end; if ct_sw then call print_totals(); end; else do; if cur_sw then process_idx = amu_info.process_idx; else call determine_process_idx(apte_offset, pid, process_idx); if process_idx >= 0 then do; if process_idx > hbound (fdump_process_table.array, 1) then call ssu_$abort_line (sci_ptr, amu_et_$big_idx, "^a.", proc_arg); hold_index = amu_info.process_idx; call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, hold_index); call amu_$fdump_mpt_change_idx (amu_info_ptr, process_idx); apte_offset = fdump_process_table.array(process_idx).apte_offset; call amu_$fdump_mpt_revert_idx (amu_info_ptr); end; apte_array_index = 0; call amu_$tc_data_get_apt_entry (amu_info_ptr, -1, convert(pidbit, pid), apte_offset, apte_array_ptr, apte_array_index); if apte_array_index = 0 & ^all_sw then call ioa_("No apte with ^[offset ^a^;process_id ^a^] found.", apte_offset>0, proc_arg); do i = 1 to apte_array_index; call amu_$print_apte (amu_info_ptr, apte_array (i).ptr, apte_array (i).off, apte_array (i).index); end; end; if apte_array_ptr ^= null() then call ssu_$release_temp_segment (sci_ptr, apte_array_ptr); return; %page; azm_requests_1_$aste: entry (P_sci_ptr, P_azm_info_ptr); dcl (aste_sw, bf_sw, pt_sw) bit (1); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); code = 0; if nargs = 0 then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage: aste segno/segname {-ctl_args}."); segno = -1; offset = -1; aste_sw, bf_sw, pt_sw, trailer_sw, no_aste_tr_info = "0"b; arg_position = 0; data_buf_ptr = null; on condition(cleanup) begin; if data_buf_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, data_buf_ptr); end; ll = get_line_length_$switch (null (), segln); /* get terminal lin length */ do argno = 1 to nargs; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if char(arg, 1) ^= "-" then do; /* assume it's a segno/segname */ arg_position = argno; end; else if arg = "-tr" | arg = "-trailer" then trailer_sw = "1"b; else if arg = "-pt" | arg = "-page_table" then pt_sw = "1"b; else if arg = "-aste" then aste_sw = "1"b; else if arg = "-bf" | arg = "-brief" then do; aste_sw, trailer_sw = "1"b; pt_sw = "0"b; end; else if arg = "-lg" | arg = "-long" then aste_sw, trailer_sw, pt_sw = "1"b; else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, """^a.""", arg); end; if arg_position = 0 then call ssu_$abort_line (sci_ptr, error_table_$noarg, " Missing the segno/segname."); else do; call ssu_$arg_ptr (sci_ptr, arg_position, argp, argl); segno = cv_oct_check_ (arg, code); if code ^= 0 then do; /* see if name */ if index(arg, "$|") > 0 then call ssu_$abort_line (sci_ptr, 0, "Segment name is not valid. It has an offset or name is a symbol. ^a", arg); call amu_$get_segno_from_name (sci_ptr, amu_info_ptr, arg, segno, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg); end; end; hardcore_cur_ptr = addr (hard_ptr_space); call amu_$hardcore_info_set_cur_ptrs (amu_info_ptr, hardcore_cur_ptr); if hardcore_cur.sstp = null then do; call ssu_$abort_line (sci_ptr, 0, "No sst."); return; end; if ^(aste_sw | trailer_sw | pt_sw) then /* set the default */ aste_sw, pt_sw = "1"b; sstp = hardcore_cur.sstp; upt_ptr = hardcore_cur.uptp; call amu_$do_translation_hunt_ptr (amu_info_ptr, pointer (baseptr (hardcore_info.dseg), (2 * segno)), sdwp, code); /* get a pointer to the SDW for the segment */ if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Cannot get pointer to SDW for SEGNO ^o.", segno); if ^(sdw.df) then call ssu_$abort_line (sci_ptr, 0, "No aste for segment ^o.", segno); if sdw.unpaged then do; /* see if the segment is paged */ call ioa_ ("Segment ^o is not paged.", segno); return; end; sdw_address = fixed (sdw.add, 26); if upt_ptr ^= null() then do; if (((sdw_address > upt.upt_absloc & sdw_address < upt.upt_last_loc)) /* found in unpaged_page_tables */ | ((sdw_address > upt.iupt_absloc & sdw_address < upt.iupt_last_loc))) /* found in int_unpaged_page_tables */ then do; no_aste_tr_info = "1"b; if aste_sw | trailer_sw then call ioa_("No ^[aste^] ^[or ^]^[trailer^] info for ^a (Seg ^o).", aste_sw, (aste_sw & trailer_sw), trailer_sw, amu_$get_name_no_comp (amu_info_ptr, baseptr (segno)), segno); end; end; if ^(no_aste_tr_info) then do; astep = pointer (sstp, fixed (sdw.add, 24) - fixed (sst.ptwbase, 18) - sst.astsize); /* get a pointer to the ast entry */ offset = fixed (rel (astep), 18) - fixed (rel (sstp), 18); call ioa_ ("ASTE For ^a (Seg ^o), at SST|^o.", amu_$get_name_no_comp (amu_info_ptr, baseptr (segno)), segno, offset); end; if aste_sw & ^(no_aste_tr_info) then do; first1 = sst.astsize; call amu_$print_dump_oct (astep, offset, first1); call amu_$slt_search_seg_ptr (hardcore_cur.sltp, hardcore_cur.sltntp, "pvt", temp_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, 0, "Cannot get pvt."); call amu_$do_translation_hunt_ptr (amu_info_ptr, temp_ptr, pvtp, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, 0, "Cannot get pvt."); pvt_arrayp = addr (pvt.array); pvtep = addr (pvt_array (aste.pvtx)); if substr (pvte.devname, 1, 3) = "dsk" then call ioa_$rsnnl ("^a device ^d", pvtx_name, ln, pvte.devname, pvte.logical_area_number); else pvtx_name = ""; call ioa_ ("^/uid = ^w, vtocx ^o on pvtx ^o^[ (^a)^]", fixed (aste.uid, 35), aste.vtocx, aste.pvtx, pvtx_name ^= "", pvtx_name); call ioa_ ("max len ^d, ^d recs used, ^d in core, cur len ^d", fixed (aste.msl, 9), fixed (aste.records, 9), fixed (aste.np, 9), fixed (aste.csl, 9)); if aste.dtu then call ioa_ ("Used ^a", dtc (aste.dtu)); else call ioa_ ("Not updated as used."); if aste.dtm then call ioa_ ("Modified ^a", dtc (aste.dtm)); else call ioa_ ("Not updated as modified."); if aste.par_astep | aste.infl | aste.infp then call ioa_ ("Par astep = ^o, Son = ^o, brother = ^o", fixed (aste.par_astep, 18), fixed (aste.infp, 18), fixed (aste.infl, 18)); if aste.uid = "0"b then call ioa_ ("Hardcore segno = ^o", fixed (aste.strp, 18)); else if aste.strp then call ioa_ ("Trailer thread = ^o", fixed (aste.strp, 18)); else call ioa_ ("No trailer thread."); if aste.dirsw then do; if aste.master_dir then call ioa_ ("Aste for a master directory."); else call ioa_ ("Aste for a directory."); end; else if aste.master_dir then call ioa_ ("Says master dir, but not directory."); if aste.quota (0) ^= 0 | aste.quota (1) ^= 0 then call ioa_ (" Quota (S D) = (^d ^d)", aste.quota (0), aste.quota (1)); if aste.used (0) ^= 0 | aste.used (1) ^= 0 then call ioa_ (" QUsed (S D) = (^d ^d)", aste.used (0), aste.used (1)); vs = ""; call ioa_$nnl ("^/"); if aste.usedf then call vput ("usedf "); if aste.init then call vput ("init "); if aste.gtus then call vput ("gtus "); if aste.hc then call vput ("hc "); if aste.hc_sdw then call vput ("hc_sdw "); if aste.any_access_on then call vput ("aaon "); if aste.write_access_on then call vput ("waccon "); if aste.inhibit_cache then call vput ("inhcch "); if aste.explicit_deact_ok then call vput ("xdok "); if aste.ehs then call vput ("ehs "); if aste.nqsw then call vput ("nqsw "); if aste.tqsw (0) then call vput ("seg-tqsw "); if aste.tqsw (1) then call vput ("dir-tqsw "); if aste.fmchanged then call vput ("fmch "); if aste.fms then call vput ("fms "); if aste.npfs then call vput ("npfs "); if aste.gtpd then call vput ("gtpd "); if aste.dnzp then call vput ("dnzp "); if aste.per_process then call vput ("per_proc "); if aste.fmchanged1 then call vput ("fmch1 "); if aste.damaged then call vput ("damaged "); if aste.ddnp then call vput ("ddnp "); if aste.pack_ovfl then call vput ("oopv "); call vput ("FLUSH"); pts = sst.pts (fixed (aste.ptsi, 3)); end; /* if aste_sw */ if pt_sw then do; /* get core map pointer */ first = fixed (baseno (sstp)); if first = fixed (baseno (sst.cmp)) then /* core map is in same seg as sst */ coremaptr = pointer (sstp, rel (sst.cmp)); else do; temp_ptr1 = sst.cmp; call ssu_$get_temp_segment (sci_ptr, "azm-data_buf", data_buf_ptr); segno = fixed (baseno (temp_ptr1), 17); first = 0; range = sys_info$max_seg_size; call get_data_ (data_buf_ptr, segno, first, range, code); if code ^= 0 then do; call ssu_$release_temp_segment(sci_ptr, data_buf_ptr); call ssu_$abort_line(sci_ptr, code, ""); end; coremaptr = addrel (data_buf_ptr, first); end; if no_aste_tr_info then do; bd_sdw = fixed (sdw.bound, 24) * 16; pts = divide (bd_sdw+1023, 1024, 18); /* always round up */ if ((sdw_address > upt.upt_absloc & sdw_address < upt.upt_last_loc)) then sptp = addrel(upt_ptr, (sdw_address - upt.upt_absloc)); else if (sdw_address > upt.iupt_absloc & sdw_address < upt.iupt_last_loc) then sptp = addrel(upt_ptr, (sdw_address - upt.iupt_absloc)); end; else sptp = addrel (astep, size (aste)); repeat_ = "0"b; /* print header only if have ptws */ if (pts - 1) >=0 then call ioa_ ("^/PAGE PT DEVADD PD COPY^/"); do i = 0 to pts - 1 by 1; ptp = addr (sptp -> ptwa (i)); devadd = ptp -> mptw.devadd; if i ^= 0 & i ^= pts - 1 & unspec (ptw) = last_ptw & devadd_add_type = "000"b & ^ptw.df then repeat_ = "1"b; else do; if repeat_ then do; repeat_ = "0"b; call ioa_ ("===="); end; else ; if ptw.df then do; core_add = fixed (devadd_record_no); core_add = divide (core_add, 16, 18, 0) + 2; if coremaptr ^= null then do; cmep = addr (coremaptr -> cma (core_add)); devadd = cme.devadd; end; else devadd = "0"b; end; str = ""; PTWF = ""; if ptw.df then call ioa_$rsnnl ("^[phu^x^]^[phm1^x^]^[nypd^x^]^[phm^x^]^[phu1^x^]^[wired^x^]^[os^x^]", PTWF,ln,ptw.phu,ptw.phm1,ptw.nypd,ptw.phm,ptw.phu1,ptw.wired,ptw.os); fdevadd = fixed (devadd_record_no); if devadd_add_type & add_type.non_null then call ioa_$rsnnl ("^6o", cdevadd, ln, fdevadd); else cdevadd = " null"; if devadd_nulled_flag & devadd_add_type = add_type.disk then do; devadd_nulled_flag = "0"b; fdevadd = fixed (devadd_record_no); call ioa_ ("^4o ^w ^6o^31t(nulled)^5x^a", i, pt_word, fdevadd, PTWF); end; else call ioa_ ("^4o ^w ^6a^31t^13x^a", i, pt_word, cdevadd, PTWF); end; last_ptw = unspec (ptw); end; end; /* if pt_sw */ if trailer_sw & ^(no_aste_tr_info) then do; if ((aste.strp ^= "0"b) & (aste.uid ^= "0"b)) then do; call ioa_ ("Known as:"); call azm_str_util_ (amu_info_ptr, aste.strp, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, ""); end; else call ioa_("^/No Trailer Information."); end; if data_buf_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, data_buf_ptr); return; %page; azm_requests_1_$config_deck: entry (P_sci_ptr, P_azm_info_ptr); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); data_buf_ptr = null; on condition(cleanup) begin; if data_buf_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, data_buf_ptr); end; reason = ""; temp_name = "config_deck"; hardcore_cur_ptr = addr (hard_ptr_space); call amu_$hardcore_info_set_cur_ptrs (amu_info_ptr, hardcore_cur_ptr); call amu_$slt_search_seg_ptr (hardcore_cur.sltp, hardcore_cur.sltntp, temp_name, temp_ptr, code); if code ^= 0 then do; reason = "config_deck not found."; goto four_letter_word; end; call ssu_$get_temp_segment (sci_ptr, "azm-cd", data_buf_ptr); range = sys_info$max_seg_size; call get_data_ (data_buf_ptr, fixed (baseno (temp_ptr), 18), 0, range, code); if code ^= 0 then do; /* set by get_data_ */ reason = "translating config deck."; go to four_letter_word; end; argno = 1; config_arg_str = ""; do argno = argno to nargs; /* build arg str to pass on to pcd */ call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if arg = "-pn" | arg = "-pathname" then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, """^a"" is not allowed within azm.", arg); config_arg_str = config_arg_str || " " || arg; end; call hcs_$fs_get_path_name (data_buf_ptr, dir_name, dir_name_lth, entryname, code); if code ^= 0 then do; call ssu_$abort_line (sci_ptr, code, "Expanding name of temp config_deck."); go to four_letter_word; end; call adjust_bit_count_(dir_name, entryname, "1"b, bitcount, code); if code ^= 0 then do; call ssu_$abort_line (sci_ptr, code, "Adjusting bitcount of temp config_deck."); go to four_letter_word; end; pcd_args = "pcd " || rtrim (config_arg_str) || " -pn " || rtrim (dir_name) || ">" || rtrim (entryname); pcd_args_len = length (pcd_args); pcd_argsp = addr (pcd_args); call cu_$cp (pcd_argsp, pcd_args_len, code); if code ^= 0 then do; reason = "Calling pcd."; go to four_letter_word; end; four_letter_word: if data_buf_ptr ^= null then call ssu_$release_temp_segment (sci_ptr, data_buf_ptr); if reason ^= "" then call ssu_$abort_line (sci_ptr, code, reason); return; %page; azm_requests_1_$display_abs: entry (P_sci_ptr, P_azm_info_ptr); mem_dump = "1"b; goto COMMON_DISPLAY; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ azm_requests_1_$display: entry (P_sci_ptr, P_azm_info_ptr); mem_dump = "0"b; COMMON_DISPLAY: call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); if af_sw then rv_str = ""; unsubscripted_name, match_names = ""; n_match_names, subscripts (*,*), n_subscripts = 0; display_ptr, copy_ptr, symbol_ptr = null(); data_buf_ptr = null(); on condition(cleanup) begin; if data_buf_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, data_buf_ptr); if display_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, display_ptr); end; unspec (modes_sw) = "0"b; long_sw, struct_sw = "0"b; process_idx = -1; if nargs = 0 then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage: ^[da ^;display {+-exp}^] {range} {-ctl_args}", mem_dump); argno = 1; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if mem_dump then do; mem_addr = cv_oct_check_ (arg, code); first = mem_addr; if code ^= 0 then call ssu_$abort_line (sci_ptr, 0, "Address to dump must be octal ""^a"".", arg); if nargs < 2 then range = 1; else do; argno = argno + 1; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); range = cv_oct_check_ (arg, code); if code ^= 0 then do; goto GET_DUMP_CTL_ARGS; /* assume ctl_arg */ end; end; argno = argno + 1; end; else do; /* display request with virtual-addr */ va_args_ptr = addr(va_args); va.range = 1; va.segno, va.offset, va.offset_modifier, va.va_position, va.ecode = 0; va.va_switches = "0"b; va.error_msg, va.va_string = ""; va.resolved_va = null(); call amu_$get_va_args(sci_ptr, amu_info_ptr, argp, nargs, va_args_ptr); if va.ecode ^= 0 | va.error_msg ^="" then call ssu_$abort_line (sci_ptr, va.ecode, "^a", va.error_msg); segno = va.segno; first = va.offset; range = va.range; end; GET_DUMP_CTL_ARGS: do argno = argno to nargs; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if arg = "-ch" | arg = "-ascii" | arg = "-character" then do; modes_sw.char_sw = "1"b; end; else if arg = "-ptr" | arg = "-p" then modes_sw.ptr_sw = "1"b; else if arg = "-pptr" | arg = "-pp" then modes_sw.pptr_sw = "1"b; else if arg = "-pptrx" | arg = "-ppx" then do; if af_sw then go to DUMP_AF_ARG_ERR; modes_sw.pptr_sw = "1"b; expand_ptr_sw = "1"b; end; else if arg = "-ptrx" | arg = "-px" then do; if af_sw then go to DUMP_AF_ARG_ERR; expand_ptr_sw = "1"b; modes_sw.ptr_sw = "1"b; end; else if arg = "-as" then do; if af_sw then go to DUMP_AF_ARG_ERR; struct_sw = "1"b; call get_next_arg("structure_name", argp, argl); outername = arg; if outername = "dte" then struct_name = "ioi_dte"; /* KLUDGE to interpret correct dte structure */ else struct_name = arg; end; else if arg = "-long" | arg = "-lg" then do; if af_sw then go to DUMP_AF_ARG_ERR; long_sw = "1"b; end; else if arg = "-inst" | arg = "-i" | arg = "-instruction" then do; if af_sw then go to DUMP_AF_ARG_ERR; modes_sw.inst_sw = "1"b; end; else if arg = "-oc" | arg = "-octal" then ; else do; if mem_dump then call ssu_$abort_line(sci_ptr, error_table_$badopt, " ^a", arg); if ^va_arg(argno) then do; if substr(arg,1,1) = "-" then code = error_table_$badopt; else code = error_table_$bad_arg; call ssu_$abort_line(sci_ptr, code, " ^a", arg); end; end; end; if (struct_sw | long_sw) & mem_dump then call ssu_$abort_line (sci_ptr, error_table_$badopt, "^[-as^;-long^].", struct_sw); if long_sw & ^struct_sw then call ssu_$abort_line (sci_ptr, 0, "-long is only valid with -as.", ""); if struct_sw & unspec (modes_sw) ^= "0"b then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-as and other control args.", ""); call ssu_$get_temp_segment (sci_ptr, "azm-display", data_buf_ptr); if struct_sw then do; call dump_as_structure(long_sw); goto END_OF_DUMP; end; if range < 0 then call ssu_$abort_line(sci_ptr, amu_et_$neg_range, "^a", va.va_string); if range = 0 then range = 1; offset = range; if modes_sw.ptr_sw then do; if mod (first, 2) ^= 0 then do; /* MUST be on even wd bndry */ call ssu_$abort_line (sci_ptr, 0, "Dump of pointer must start on even word boundary."); go to END_OF_DUMP; end; temp_range = range * 2; go to GET_DUMP_DATA; end; if range = 1 then temp_range = 2; else temp_range = range; GET_DUMP_DATA: if mem_dump then do; call azm_dump_mem_ (amu_info_ptr, mem_addr, process_idx, segno, first, mem_tag, is_wired, is_paged, code); if code ^= 0 then do; if af_sw then go to DUMP_AF_ERROR; if code = amu_et_$free_core then do; call ioa_ ("^/Mem Addr ^8o is in free core (MEM ^a).", mem_addr, substr (CPU_NAME, (mem_tag + 1), 1)); goto END_OF_DUMP; end; if code = amu_et_$proc_not_dumped then do; call ioa_ ("^/Mem Addr ^8o (MEM ^a) owned by a process not dumped (SEGNO ^o).", mem_addr, substr (CPU_NAME, (mem_tag + 1), 1), segno); goto END_OF_DUMP; end; call ssu_$abort_line (sci_ptr, code, ""); end; call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, process_idx); index_changed = "1"b; end; /* of if mem_dump */ temp_ptr = pointer (baseptr (segno), first); if ^modes_sw.inst_sw then call get_data_ (data_buf_ptr, segno, first, temp_range, code); else call hunt_for_code (segno, first, temp_range); chk_range: if temp_range = 0 then call ssu_$abort_line (sci_ptr, 0, "Location ^o not found in Seg ^o.", first + range, segno); if code ^= 0 then do; if code = amu_et_$seg_not_dumped & ^modes_sw.inst_sw then do; call ssu_$print_message (sci_ptr, code, " ^o|^o ^|^10xGetting data from the online storage.", segno, range); code = 0; call hunt_for_code (segno, first, temp_range); goto chk_range; end; if data_buf_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, data_buf_ptr); call ssu_$abort_line (sci_ptr, code, " ^o|^o", segno, range); end; if af_sw then do; if temp_range < range then range = temp_range; go to DUMP_AF; end; else if temp_range < range then do; range = temp_range; call ioa_ ("Last loc is ^o range will be ^o",(first + range),range); end; real_address = mem_addr; if mem_dump then call azm_find_mem_box_$bf (amu_info_ptr, real_address, segno, first, code); call ioa_ ("^[ABS_WIRED ^]^[Un-Paged ^]^[Paged ^]Segno ^o ^a^[,Owned by Process index ^d:^]", (mem_dump & is_wired), (mem_dump & ^is_paged), (mem_dump & is_paged), segno, amu_$get_name (amu_info_ptr, temp_ptr), process_idx^= -1, process_idx); if unspec (modes_sw) = "0"b then do; if mod (first, 2) = 0 then do; /* check for its pointer */ if range = 1 then do; if data_buf_ptr -> its.its_mod = ITS_MODIFIER | data_buf_ptr -> its.its_mod = ITP_MODIFIER then range = 2; end; end; call amu_$print_dump_oct (data_buf_ptr, first, range); end; else if modes_sw.ptr_sw then do; range = mod(range,2) + range; if expand_ptr_sw = "0"b then call amu_$print_dump_ptr (data_buf_ptr, first, range); else call amu_$print_dump_ptr_exp (amu_info_ptr, data_buf_ptr, first, range); end; else if modes_sw.pptr_sw then do; if expand_ptr_sw = "0"b then call amu_$print_dump_pptr (data_buf_ptr, first, range); else call amu_$print_dump_pptr_exp (amu_info_ptr, data_buf_ptr, first, range); end; else if modes_sw.char_sw then do; call amu_$print_char_dump (data_buf_ptr, first, range); end; else if modes_sw.inst_sw then do; call amu_$print_inst_dump (data_buf_ptr, first, range); end; if offset > range then call ioa_ ("dump: Offset ^o not found in Seg ^o, Last location = ^o.", first + offset, segno, (first + range) - 1); go to END_OF_DUMP; DUMP_AF: if unspec (modes_sw) = "0"b then /* octal dump */ call ioa_$rsnnl ("^v(^w ^)", rv_str, ignore, range, RS); else if modes_sw.ptr_sw then /* as a ptr */ call ioa_$rsnnl ("^v(^p ^)", rv_str, ignore, range, RSP); else if modes_sw.pptr_sw then /* as a packed ptr */ call ioa_$rsnnl ("^v(^p ^)", rv_str, ignore, range, RSPP); else if modes_sw.char_sw then call amu_$print_char_dump_af (data_buf_ptr, first, range, rv_ptr, rv_lth); END_OF_DUMP: if index_changed = "1"b then do; call amu_$fdump_mpt_revert_idx (amu_info_ptr); index_changed = "0"b; end; if data_buf_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, data_buf_ptr); return; /* end of dump entry */ DUMP_AF_ARG_ERR: if data_buf_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, data_buf_ptr); call ssu_$abort_line (sci_ptr, 0, "^a not available in the active request.", arg); return; DUMP_AF_ERROR: if data_buf_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, data_buf_ptr); call ssu_$abort_line (sci_ptr, code, ""); return; %page; azm_requests_1_$ds: entry (P_sci_ptr, P_azm_info_ptr); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No Dump has been specified."); if nargs = 0 then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage: ds {+-offset_modifier} {range} {-ctl_args}"); display_ptr, copy_ptr, symbol_ptr = null(); data_buf_ptr = null(); on condition(cleanup) begin; if data_buf_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, data_buf_ptr); if display_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, display_ptr); end; /* init va_args */ va_args_ptr = addr(va_args); va.range = 1; va.segno, va.offset, va.offset_modifier, va.va_position, va.ecode = 0; va.va_switches = "0"b; va.error_msg, va.va_string = ""; va.resolved_va = null(); call ssu_$arg_ptr (sci_ptr, 1, argp, argl); call amu_$get_va_args(sci_ptr, amu_info_ptr, argp, nargs, va_args_ptr); if va.ecode ^= 0 | va.error_msg ^="" then do; call ssu_$abort_line (sci_ptr, va.ecode, "^a", va.error_msg); end; /* Set defaults for the call to dump_segment_. These don't necessary related to what the user specified on the request line */ dump_segment_format_structure = "0"b; dump_segment_format_structure.octal, dump_segment_format_structure.offset, dump_segment_format_structure.raw_data, dump_segment_format_structure.suppress_duplicates, dump_segment_format_structure.interpreted_data = "1"b; if af_sw then do; /* set defaults for active_request */ dump_segment_format_structure.suppress_duplicates, /* -nsd */ dump_segment_format_structure.interpreted_data, /* -nit */ dump_segment_format_structure.offset = "0"b; /* -no_address */ end; /* init other things */ process_idx = -1; block, code = 0; unsubscripted_name, match_names = ""; n_match_names, subscripts (*,*), n_subscripts = 0; if af_sw then header_sw = "0"b; /* no header for active request */ else header_sw = "1"b; /* default is to print header */ struct_sw, long_sw, index_changed = "0"b; argno = 1; do argno = argno to nargs; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if (arg = "-long" | arg = "-lg") then do; dump_segment_format_structure.long, long_sw = "1"b; dump_segment_format_structure.short = "0"b; end; else if (arg = "-suppress_duplicates" | arg = "-sd") then do; if af_sw then goto AF_DS_ERROR; dump_segment_format_structure.suppress_duplicates = "1"b; end; else if (arg = "-no_suppress_duplicates" | arg = "-nsd") then dump_segment_format_structure.suppress_duplicates = "0"b; else if arg = "-raw" then dump_segment_format_structure.raw_data = "1"b; else if arg = "-no_raw" | arg = "-nraw" then dump_segment_format_structure.raw_data = "0"b; else if arg = "-interpreted" | arg = "-it" then do; if af_sw then goto AF_DS_ERROR; dump_segment_format_structure.interpreted_data = "1"b; end; else if arg = "-no_interpret" | arg = "-nit" then dump_segment_format_structure.interpreted_data = "0"b; else if arg = "-character" | arg = "-ch" | arg = "-ascii" then do; dump_segment_format_structure.ascii, dump_segment_format_structure.interpreted_data = "1"b; dump_segment_format_structure.bit4, dump_segment_format_structure.ebcdic8, dump_segment_format_structure.ebcdic9, dump_segment_format_structure.bcd = "0"b; end; else if arg = "-bcd" then do; dump_segment_format_structure.bcd, dump_segment_format_structure.interpreted_data = "1"b; dump_segment_format_structure.ascii, dump_segment_format_structure.bit4, dump_segment_format_structure.ebcdic8, dump_segment_format_structure.ebcdic9 = "0"b; end; else if arg = "-ebcdic9" then do; dump_segment_format_structure.ebcdic9, dump_segment_format_structure.interpreted_data = "1"b; dump_segment_format_structure.ascii, dump_segment_format_structure.bit4, dump_segment_format_structure.ebcdic8 = "0"b; end; else if arg = "-ebcdic8" then do; dump_segment_format_structure.ebcdic8, dump_segment_format_structure.interpreted_data = "1"b; dump_segment_format_structure.ascii, dump_segment_format_structure.bit4, dump_segment_format_structure.ebcdic9 = "0"b; end; else if arg = "-4bit" then do; dump_segment_format_structure.bit4, dump_segment_format_structure.interpreted_data = "1"b; dump_segment_format_structure.ascii, dump_segment_format_structure.ebcdic8, dump_segment_format_structure.ebcdic9 = "0"b; end; else if arg = "-hex8" then do; dump_segment_format_structure.hex8, dump_segment_format_structure.raw_data = "1"b; dump_segment_format_structure.hex9, dump_segment_format_structure.octal = "0"b; end; else if arg = "-hex9" then do; dump_segment_format_structure.hex9, dump_segment_format_structure.raw_data = "1"b; dump_segment_format_structure.hex8, dump_segment_format_structure.octal = "0"b; end; else if arg = "-octal" | arg = "-oc" then do; dump_segment_format_structure.octal, dump_segment_format_structure.raw_data = "1"b; dump_segment_format_structure.hex8, dump_segment_format_structure.hex9 = "0"b; end; else if (arg = "-short" | arg = "-sh") then do; dump_segment_format_structure.short = "1"b; dump_segment_format_structure.long = "0"b; end; else if (arg = "-address" | arg = "-addr") then do; if af_sw then goto AF_DS_ERROR; dump_segment_format_structure.offset = "1"b; end; else if (arg = "-no_address" | arg = "-naddr") then dump_segment_format_structure.offset = "0"b; else if arg = "-as" then do; if af_sw then goto AF_DS_ERROR; struct_sw = "1"b; call get_next_arg("structure_name", argp, argl); outername, struct_name = arg; end; else if (arg = "-header" | arg = "-he") then do; if af_sw then goto AF_DS_ERROR; header_sw = "1"b; end; else if (arg = "-no_header" | arg = "-nhe") then header_sw = "0"b; else if (arg = "-block" | arg = "-bk") then do; if af_sw then goto AF_DS_ERROR; call get_next_arg("block size", argp, argl); /* check next arg, if octal then use as offset */ block = cv_oct_check_ (arg, code); if code ^= 0 then call ssu_$abort_line(sci_ptr, 0, "block size is non-octal ^a", arg); end; else do; if ^va_arg(argno) then do; if substr(arg,1,1) = "-" then code = error_table_$badopt; else code = error_table_$bad_arg; call ssu_$abort_line(sci_ptr, code, " ^a", arg); end; end; end; /* arg processing */ /* Check for legal formats and finish setting variables */ if struct_sw then call ssu_$print_message(sci_ptr, 0, "For now other control args are ignored except -lg.^/"); call ssu_$get_temp_segment (sci_ptr, "azm-display", data_buf_ptr); segno = va.segno; first = va.offset; range = va.range; if struct_sw then do; call dump_as_structure(dump_segment_format_structure.long); goto END_OF_DS; end; temp_ptr = pointer (baseptr (segno), first); call hunt_for_code (segno, first, temp_range); if mod (first, 2) = 0 then do; /* check for its pointer */ if range = 1 then do; if data_buf_ptr -> its.its_mod = ITS_MODIFIER | data_buf_ptr -> its.its_mod = ITP_MODIFIER then range = 2; end; end; if header_sw then call ioa_ ("Segno ^o ^a^[,Owned by Process index ^d:^]^/", segno, amu_$get_name (amu_info_ptr, temp_ptr), process_idx^= -1, process_idx); dump_segment_format_structure.command_output = "1"b; if af_sw then do; rv_str = ""; call dump_segment_$string(rv_ptr, rv_lth, data_buf_ptr, block, first, range, dump_segment_format); end; else call dump_segment_(iox_$user_output, data_buf_ptr, block, first, range, dump_segment_format); END_OF_DS: if index_changed = "1"b then do; call amu_$fdump_mpt_revert_idx (amu_info_ptr); index_changed = "0"b; end; if data_buf_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, data_buf_ptr); return; /* end of dump entry */ AF_DS_ERROR: call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg); return; %page; azm_requests_1_$extract_seg: entry (P_sci_ptr, P_azm_info_ptr); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); if nargs < 2 then call ssu_$abort_line(sci_ptr, error_table_$noarg, "^/Usage: ap virtual-addr {range} command_line"); /* init va_args */ va_args_ptr = addr(va_args); va.range = 0; va.segno, va.offset, va.offset_modifier, va.va_position, va.ecode = 0; va.va_switches = "0"b; va.error_msg, va.va_string = ""; va.resolved_va = null(); call ssu_$arg_ptr (sci_ptr, 1, argp, argl); call amu_$get_va_args(sci_ptr, amu_info_ptr, argp, nargs, va_args_ptr); if va.ecode ^= 0 | va.error_msg ^="" then do; call ssu_$abort_line (sci_ptr, va.ecode, "^a", va.error_msg); end; command_arg = -1; do argno = 1 to nargs; /* looping to catch any invalid args */ call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if ^va_arg(argno) then do; if command_arg < 0 then command_arg = argno; else call ssu_$abort_line(sci_ptr, error_table_$bad_arg, " ^a", arg); end; end; /* arg processing */ range = va.range; segno = va.segno; first = va.offset; if range = 0 then range = sys_info$max_seg_size; data_buf_ptr = null (); on cleanup begin; if data_buf_ptr ^= null () then call ssu_$release_temp_segment (sci_ptr, data_buf_ptr); end; call ssu_$get_temp_segment (sci_ptr, "azm-apply", data_buf_ptr); call get_data_ (data_buf_ptr, segno, first, range, code); if code ^= 0 then do; call ssu_$release_temp_segment (sci_ptr, data_buf_ptr); call ssu_$abort_line (sci_ptr, code, "No translation."); end; call ssu_$apply_request_util (sci_ptr, command_arg, data_buf_ptr, (range * 4), new_range); call ssu_$release_temp_segment (sci_ptr, data_buf_ptr); revert cleanup; return; /* end of extract_seg */ %page; azm_requests_1_$history_regs: entry (P_sci_ptr, P_azm_info_ptr); dcl want_both bit(1); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); hregs_from_dump, hregs_fm_ptrval, cond_frame, hregs_from_pds = "0"b; interpreted_hregs, octal_sw, want_both = "0"b; only_cu, only_ou, only_au, only_du = "0"b; threaded_hregs = "1"b; /* default */ data_buf_ptr = null(); on condition(cleanup) begin; if data_buf_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, data_buf_ptr); end; do argno = 1 to nargs; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if char(arg, 1) ^= "-" then do; /* assume it's a virtual-addr */ if hregs_fm_ptrval then call ssu_$abort_line(sci_ptr, error_table_$bad_arg, "Or virtual address specified more than once. ^a", arg); hregs_fm_ptrval = "1"b; arg_position = argno; end; else if arg = "-dump" then do; if amu_info.type = SAVED_PROC_TYPE then call ssu_$abort_line(sci_ptr, 0, "-dump is not applicable for analyzing process dirs."); dumpptr = fdump_info.dump_seg_ptr (0); temp_ptr = addr (dump.ouhist); hregs_from_dump = "1"b; end; else if arg = "-pds" then do; hregs_from_pds = "1"b; end; else if arg = "-cond" | arg = "-condition" then do; cond_frame = "1"b; call get_next_arg("virtual-addr", argp, argl); arg_position = argno; end; else if arg = "-cu" then do; only_cu = "1"b; threaded_hregs = "0"b; end; else if arg = "-ou" then do; only_ou = "1"b; threaded_hregs = "0"b; end; else if arg = "-au" then do; only_au = "1"b; threaded_hregs = "0"b; end; else if arg = "-du" then do; only_du = "1"b; threaded_hregs = "0"b; end; else if arg = "-no_thread" then do; threaded_hregs = "0"b; end; else if arg = "-octal" | arg = "-oc" then do; octal_sw = "1"b; end; else if arg = "-interpret" then do; interpreted_hregs = "1"b; end; else if arg = "-thread" then do; threaded_hregs = "1"b; end; else call ssu_$abort_line(sci_ptr, error_table_$bad_arg, "^a", arg); end; /* arg processing do loop */ if ^(hregs_from_dump | hregs_fm_ptrval | cond_frame | hregs_from_pds) then hregs_from_pds = "1"b; /* set the default */ else if ((hregs_from_dump & hregs_fm_ptrval) | (hregs_from_dump & hregs_from_pds) | (hregs_from_dump & cond_frame) | (hregs_fm_ptrval & cond_frame) | (hregs_fm_ptrval & hregs_from_pds)) then call ssu_$abort_line(sci_ptr, error_table_$inconsistent, "^[ -dump^]^[ -pds^]^[ -cond^]^[ virtual-addr^]", hregs_from_dump, hregs_from_pds, cond_frame, hregs_fm_ptrval); if ^(only_cu | only_ou | only_au | only_du) then only_au, only_cu, only_ou = "1"b; /* set the default */ if octal_sw then do; if interpreted_hregs then want_both = "1"b; end; else interpreted_hregs = "1"b; /* set default */ if (hregs_fm_ptrval | cond_frame) then do; /* get the virtual addr */ /* init va_args */ va_args_ptr = addr(va_args); va.range = 0; va.segno, va.offset, va.offset_modifier, va.va_position, va.ecode = 0; va.va_switches = "0"b; va.error_msg, va.va_string = ""; va.resolved_va = null(); call amu_$get_va_args_given_start(sci_ptr, amu_info_ptr, argp, arg_position, nargs, va_args_ptr); if va.ecode ^= 0 | va.error_msg ^="" then call ssu_$abort_line (sci_ptr, va.ecode, "^a", va.error_msg); segno = va.segno; first = va.offset; end; call ssu_$get_temp_segment (sci_ptr, "azm-hregs", data_buf_ptr); if cond_frame then do; sp = addrel (baseptr (segno), first); /* get stk ptr */ /* get ret ptr */ temp_ptr1 = addr (stack_frame.return_ptr); segno1 = fixed (baseno (temp_ptr1), 18); first1 = fixed (rel (temp_ptr1), 18); range = 2; call get_data_ (data_buf_ptr, segno1, first1, range, code); if code ^= 0 then goto HREGS_RETURN; ret_str = amu_$get_name (amu_info_ptr, ret_ptr); if index (ret_str, "return_to_ring_") ^= 0 | index (ret_str, "signaller") ^= 0 then do; sigstp = addrel (addr (stack_frame.timer), +1); temp_ptr1 = addr (sig_stack.history_registers); first = fixed (rel (temp_ptr1), 18); go to END_HR_ARGS; end; else if index (ret_str, "fim") ^= 0 then do; first = first + 96; /* from fim */ go to END_HR_ARGS; end; else call ssu_$abort_line (sci_ptr, 0, "^p is not a condition frame.", addrel (baseptr (segno), first)); end; END_HR_ARGS: range = 128; /* need 128 words */ hr_switches = interpreted_hregs || only_ou || only_cu || only_au || only_du; if hregs_from_pds then do; /* default is pds */ temp_ptr = amu_$definition_ptr (amu_info_ptr, "pds", "history_reg_data", code); if code ^= 0 then do; call ssu_$abort_line (sci_ptr, code, ""); return; end; segno = fixed (baseno (temp_ptr), 17); first = fixed (rel (temp_ptr), 18); end; temp_ptr1 = addrel (baseptr (segno), first); call ioa_ ("History Registers at ^[(^p) ^a^;^2s^]^[time of Dump from Bootload CPU^]", ^hregs_from_dump, temp_ptr1, amu_$get_name (amu_info_ptr, temp_ptr1), hregs_from_dump); if hregs_from_dump then do; if threaded_hregs then do; if want_both | octal_sw then call hran_$hran_bos (temp_ptr, null(), "1"b); else call hran_$hran_bos (temp_ptr, null (), "0"b); end; else do; /* not threaded */ if want_both then do; call hran_$bos_no_thread (temp_ptr, null(), hr_switches); hr_switches = "0"b || only_ou || only_cu || only_au || only_du; call hran_$bos_no_thread (temp_ptr, null(), hr_switches); /* also display the octal representation */ end; else call hran_$bos_no_thread (temp_ptr, null(), hr_switches); end; return; /* all done */ end; /* get hregs from the pds */ call get_data_ (data_buf_ptr, segno, first, range, code); if code ^= 0 then goto HREGS_RETURN; if threaded_hregs then do; if want_both | octal_sw then call hran_$hranl (data_buf_ptr, null, "1"b); else call hran_$hranl (data_buf_ptr, null, "0"b); end; else do; /* not threaded */ if want_both then do; call hran_$no_thread (data_buf_ptr, null, hr_switches); hr_switches = "0"b || only_ou || only_cu || only_au || only_du; call hran_$no_thread (data_buf_ptr, null, hr_switches); /* also display the octal representation */ end; else call hran_$no_thread (data_buf_ptr, null, hr_switches); end; HREGS_RETURN: if data_buf_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, data_buf_ptr); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, ""); return; %page; azm_requests_1_$list_proc: entry (P_sci_ptr, P_azm_info_ptr); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No current dump selected."); call process_common_args(); if ^proc_sw then do; if cur_sw then do; if af_sw then call amu_$fdump_mpt_current_process_af (amu_info_ptr, rv_ptr, rv_lth); else call amu_$fdump_mpt_current_process (amu_info_ptr); end; else call list_by_state(); goto END_LSP; end; call determine_process_idx (apte_offset, pid, process_idx); if process_idx >= 0 then do; if process_idx > hbound (fdump_process_table.array, 1) then call ssu_$abort_line (sci_ptr, amu_et_$big_idx, "^a.", proc_arg); hold_index = amu_info.process_idx; call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, hold_index); call amu_$fdump_mpt_change_idx (amu_info_ptr, process_idx); if af_sw then call amu_$fdump_mpt_current_process_af (amu_info_ptr, rv_ptr, rv_lth); else call amu_$fdump_mpt_current_process (amu_info_ptr); call amu_$fdump_mpt_revert_idx (amu_info_ptr); goto END_LSP; end; if pid > 0 then do; /* match on process-ids to get the process_idx */ pidbit = convert(pidbit, pid); hold_index = amu_info.process_idx; call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, hold_index); found = "0"b; do i = 0 to hbound (fdump_process_table.array, 1) while (^found); call amu_$fdump_mpt_change_idx (amu_info_ptr, i); Pproc = fdump_process_table.array(i).process_info_ptr; if Pproc->process_info.pid = pidbit then do; found = "1"b; if af_sw then call amu_$fdump_mpt_current_process_af (amu_info_ptr, rv_ptr, rv_lth); else call amu_$fdump_mpt_current_process (amu_info_ptr); end; end; call amu_$fdump_mpt_revert_idx (amu_info_ptr); if ^(found) then call ssu_$abort_line (sci_ptr, 0, "Process with id ^a not found in dump.", proc_arg); goto END_LSP; end; if apte_offset > 0 then do; hold_index = amu_info.process_idx; call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, hold_index); found = "0"b; do i = 0 to hbound (fdump_process_table.array, 1) while (^found); call amu_$fdump_mpt_change_idx (amu_info_ptr, i); if apte_offset = fdump_process_table(i).apte_offset then do; found = "1"b; if af_sw then call amu_$fdump_mpt_current_process_af (amu_info_ptr, rv_ptr, rv_lth); else call amu_$fdump_mpt_current_process (amu_info_ptr); end; end; call amu_$fdump_mpt_revert_idx (amu_info_ptr); if ^(found) then call ssu_$abort_line (sci_ptr, 0, "Process with APTE offset ^a not found in dump.", proc_arg); end; END_LSP: return; %page; /* Entry is for displaying machine condition frames */ azm_requests_1_$mc: entry (P_sci_ptr, P_azm_info_ptr); dcl 1 what_regs based (arg_bits_ptr) aligned, 2 dont_care bit(6) unal, 2 registers bit(11) unal, 2 dont_care2 bit(18) unal; dcl (dump_sw, args_specified, va_sw) bit(1); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); data_buf_ptr = null(); on condition(cleanup) begin; if data_buf_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, data_buf_ptr); end; code, range1 = 0; dump_sw, va_sw, args_specified, octal_sw = "0"b; mcp_pgflt_sw, mcp_fim_sw, mcp_sig_sw = "0"b; mcpr_int_sw, mcpr_fim_sw, mcpr_systroub_sw, all_sw = "0"b; pds_sw, prds_sw, cond_frame, mc_from_ptrval = "0"b; arg_bits_ptr = addr (mc_arg); mc_arg = "0"b; arg_bits_def.set_ptr = "1"b; /* always set temp ptrs when mc request is called */ if nargs = 0 then do; /* default to -scu -pr6 and the prmc value if ^= null() */ first_ptr_arg = 0; arg_bits_def.scu, arg_bits_def.pr (6) = "1"b; arg_bits_def.tpr, arg_bits_def.mc_err = "1"b; arg_bits_def.flt, arg_bits_def.tm = "1"b; arg_bits_def.eis = "1"b; t_pr_name = "prmc"; call amu_$definition_get_prn (amu_info_ptr, t_pr_name, temp_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "The MC pointer 'prmc' is not set."); if temp_ptr = null () then call ssu_$abort_line (sci_ptr, 0, "The machine condition pointer 'prmc' is not set. See the set request."); segno = fixed (baseno (temp_ptr), 17); first = fixed (rel (temp_ptr), 18); goto READY_TO_PRINT; end; /* process arguments */ /* init va_args */ va_args_ptr = addr(va_args); va.range = -1; va.segno, va.offset, va.offset_modifier, va.va_position, va.ecode = 0; va.va_switches = "0"b; va.error_msg, va.va_string = ""; va.resolved_va = null(); call ssu_$arg_ptr (sci_ptr, 1, argp, argl); call amu_$get_va_args(sci_ptr, amu_info_ptr, argp, nargs, va_args_ptr); if va.valid_va then va_sw = "1"b; va.range_idx = 0; /* A range is not valid for mc request */ segno = va.segno; first = va.offset; do argno = 1 to nargs; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if arg = "-dump" then do; /* want mc at the time of the FDUMP */ if amu_info.type = SAVED_PROC_TYPE then call ssu_$abort_line(sci_ptr, 0, "-dump is not applicable for analyzing process dirs."); if amu_info.type = FDUMP_TYPE | amu_info.type = FDUMP_PROCESS_TYPE then do; data_buf_ptr = fdump_info.dump_seg_ptr (0); arg_bits_def.dump = "1"b; dump_sw = "1"b; end; else call ssu_$abort_line (sci_ptr, 0, "Translation is not an FDUMP."); end; else if arg = "-pds" then do; pds_sw = "1"b; call get_mc_specifiers(); end; else if arg = "-prds" then do; if amu_info.type = SAVED_PROC_TYPE then call ssu_$abort_line(sci_ptr, 0, "-prds is not applicable for analyzing process dirs."); prds_sw = "1"b; call get_mc_specifiers(); end; else if arg = "-misc" then args_specified, arg_bits_def.mis = "1"b; else if arg = "-mc_err" then args_specified, arg_bits_def.mc_err = "1"b; else if arg = "-flt" | arg = "-faults" then args_specified, arg_bits_def.flt = "1"b; else if arg = "-tm" | arg = "-time" then args_specified, arg_bits_def.tm = "1"b; else if arg = "-eis" then args_specified, arg_bits_def.eis = "1"b; else if arg = "-lg" | arg = "-long" then args_specified, arg_bits_def.all = "1"b; else if arg = "-oc" | arg = "-octal" then args_specified, octal_sw = "1"b; else if arg = "-scu" then args_specified, arg_bits_def.scu = "1"b; else if arg = "-ppr" then args_specified, arg_bits_def.ppr = "1"b; else if arg = "-tpr" then args_specified, arg_bits_def.tpr = "1"b; else if arg = "-regs"| arg = "-registers" then do; args_specified = "1"b; call get_mc_reg_list(); end; else if arg = "-prs"| arg = "-pointers" then do; args_specified = "1"b; call get_mc_pr_list(); end; else do; if ^va_arg(argno) then do; if substr(arg,1,1) = "-" then code = error_table_$badopt; else code = error_table_$bad_arg; call ssu_$abort_line(sci_ptr, code, " ^a", arg); end; end; end; /* arg processing */ if (dump_sw & prds_sw) | (dump_sw & pds_sw) | (dump_sw & va_sw) | (prds_sw & pds_sw) | (prds_sw & va_sw) | (pds_sw & va_sw) then call ssu_$abort_line(sci_ptr, error_table_$inconsistent, " ^[virtual-address ^]^[-prds ^]^[-pds ^]^[-dump ^]", va_sw, prds_sw, pds_sw, dump_sw); if ^(args_specified) then do; /* set the default */ arg_bits_def.scu, arg_bits_def.pr (6) = "1"b; arg_bits_def.tpr, arg_bits_def.mc_err = "1"b; arg_bits_def.flt, arg_bits_def.tm = "1"b; end; else if octal_sw then do; if (index (what_regs.registers, "1"b) > 0) | arg_bits_def.eis | arg_bits_def.scu | arg_bits_def.all then arg_bits_def.long = "1"b; else call ssu_$abort_line(sci_ptr, error_table_$noarg, "^/ -octal is used in conjunction with -scu | -regs | -eis."); end; if ^(dump_sw | prds_sw | pds_sw | va_sw) then do; /* use the default value from prmc if not set then error */ t_pr_name = "prmc"; call amu_$definition_get_prn (amu_info_ptr, t_pr_name, temp_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "The MC pointer 'prmc' is not set."); if temp_ptr = null () then call ssu_$abort_line (sci_ptr, 0, "The machine condition pointer 'prmc' is not set. See the set request."); segno = fixed (baseno (temp_ptr), 17); first = fixed (rel (temp_ptr), 18); end; if prds_sw | pds_sw then do; call mc_by_keyword(); goto END_MC; end; if va_sw then do; call ssu_$get_temp_segment (sci_ptr, "azm-mc", data_buf_ptr); call get_stack (segno, code); /* returns stack base ptr if a stack */ if code ^= 0 then do; if code = amu_et_$not_stack_seg then do; goto READY_TO_PRINT; end; else call ssu_$abort_line(sci_ptr, code); end; sp = addrel (sb, first); /* get stk frame ptr */ /* get return ptr */ temp_ptr1 = stack_frame.return_ptr; segno1 = fixed (baseno (temp_ptr1), 18); first1 = fixed (rel (temp_ptr1), 18); range1 = 2; ret_str = amu_$get_name (amu_info_ptr, temp_ptr1); if index (ret_str, "return_to_ring_0") > 0 | index (ret_str, "signaller") > 0 | index (ret_str, "$fim") ^= 0 then first = first+48; /* goto where machine conditions start in frame */ else; /* use what the user says */ end; READY_TO_PRINT: call ioa_ ("Machine Conditions from ^[(^p) ^a^;^2s^]^[Dump^].", ^arg_bits_def.dump, addrel (baseptr (segno), first), amu_$get_name (amu_info_ptr, addrel (baseptr (segno), first)), arg_bits_def.dump); call common_mc(); END_MC: if data_buf_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, data_buf_ptr); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, ""); return; /* end mc entry */ %page; azm_requests_1_$sdw: entry (P_sci_ptr, P_azm_info_ptr); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); if nargs > 2 then call ssu_$abort_line(sci_ptr, error_table_$too_many_args, "^/Usage: sdw {segno/name} {segno/name}."); segno = hardcore_info.dseg; code = 0; data_buf_ptr = null(); on condition(cleanup) begin; if data_buf_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, data_buf_ptr); end; first_segno = 0; /* set up default range */ last_segno = divide (sys_info$max_seg_size, 2, 17, 0) - 1; if nargs = 0 then goto GET_SDWS; /* wants it ALL */ /* First argument will be a segno/name */ call ssu_$arg_ptr (sci_ptr, 1, argp, argl); first_segno = cv_oct_check_ (arg, code); if code ^= 0 then do; /* see if name */ if index(arg, "$|") > 0 then call ssu_$abort_line (sci_ptr, 0, "Segment name is not valid. It has an offset or name is a symbol. ^a", arg); call amu_$get_segno_from_name (sci_ptr, amu_info_ptr, arg, first_segno, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg); end; if nargs = 2 then do; call ssu_$arg_ptr (sci_ptr, 2, argp, argl); last_segno = cv_oct_check_ (arg, code); if code ^= 0 then do; /* see if name */ if index(arg, "$|") > 0 then call ssu_$abort_line (sci_ptr, 0, "Segment name is not valid. It has an offset or name is a symbol. ^a", arg); call amu_$get_segno_from_name (sci_ptr, amu_info_ptr, arg, last_segno, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg); end; end; else last_segno = first_segno; if first_segno > last_segno then call ssu_$abort_line (sci_ptr, code, "The starting segment number ^o must be less than then ending segment ^o.", first_segno, last_segno); if last_segno > divide (sys_info$max_seg_size, 2, 17, 0) - 1 then call ssu_$abort_line (sci_ptr, code, "The ^o specified is too large to be contained in DSEG.", last_segno); GET_SDWS: if first_segno = last_segno then range, range1 = 2; else range, range1 = ((last_segno + 1) * 2) - (first_segno * 2); call ssu_$get_temp_segment (sci_ptr, "azm-sdw", data_buf_ptr); call get_data_ (data_buf_ptr, segno, (first_segno * 2), range, code); if range < range1 then do; i = last_segno - divide ((range1 - range), 2, 0, 17); if nargs = 0 then call ioa_ ("Segment ^o is not known to this process^[, last known segment is ^o^].", last_segno, first_segno ^= last_segno, i); if last_segno = first_segno | first_segno > i then go to SDWERR; last_segno = i; end; hdr_printed = "0"b; sdwp = data_buf_ptr; do segno = first_segno to last_segno; call ioa_$rsnnl ("^[R^; ^]^[E^; ^]^[W^; ^]^[P^; ^]^[U^; ^]^[G^; ^]^[C^; ^]^[DF^; ^]", axstring, (0), /* generate the REWPUGCDF string */ sdw.read, sdw.execute, sdw.write, sdw.privileged, sdw.unpaged, sdw.entry_bound_sw, sdw.cache, sdw.df); if ^hdr_printed then call ioa_ (" ADDRESS RNGS CA-MAX REWPUGCDF EBOUND SEGNO SEGMENT-NAME"); hdr_printed = "1"b; call ioa_ ("^8o ^.3b^.3b^.3b ^6o ^9a ^6o ^5o ^a", fixed (sdw.add, 24), sdw.r1, sdw.r2, sdw.r3, ((fixed ("0"b || sdw.bound, 18) + 1) * 16) - 1, axstring, fixed (sdw.entry_bound, 14), segno, amu_$get_name_no_comp (amu_info_ptr, baseptr (segno))); if sdw.df_no ^= "0"b then call ioa_ ("****The sdw.df_no is ^.3b, should be 0****", "0"b || sdw.df_no); sdwp = addrel (sdwp, 2); end; /* end loop */ SDWERR: if data_buf_ptr ^= null then call ssu_$release_temp_segment (sci_ptr, data_buf_ptr); if ^(hdr_printed) then call ioa_ ("No valid SDW^[s^] found (^o^[ - ^o^]).", first_segno ^= last_segno, first_segno, first_segno ^= last_segno, last_segno); return; %page; azm_requests_1_$select_proc: entry (P_sci_ptr, P_azm_info_ptr); dcl found bit(1); dcl Pproc ptr; call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No current dump selected."); proc_ptr = null(); proc_sw, dbr_sw, brief_sw, cpu_sw = "0"b; dbr, pid, apte_offset = 0; cpu_name = ""; process_idx = -1; if nargs = 0 then do; process_idx = amu_info.process_idx; goto PRINT_CURRENT; end; do argno = 1 to nargs; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if substr (arg, 1, 1) ^= "-" then do; procl = argl; proc_ptr = argp; proc_arg = arg; proc_sw = "1"b; end; else if arg = "-cpu" then do; call get_next_arg ("CPU tag", proc_ptr, procl); cpu_sw = "1"b; end; else if arg = "-dbr" then do; call get_next_arg ("dbr_value", proc_ptr, procl); dbr_sw = "1"b; end; else if arg = "-bf" | arg = "-brief" then brief_sw = "1"b; else if arg = "-lg" | arg = "-long" then brief_sw = "0"b; else do; call ssu_$abort_line (sci_ptr, error_table_$badopt, "Not a valid arg ""^a"".", arg); end; end; if proc_sw & (dbr_sw | cpu_sw) then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "process_specifier and^[ -dbr^]^[ -cpu^]", dbr_sw, cpu_sw); if ^(proc_sw) then if ^(dbr_sw | cpu_sw) then call ssu_$abort_line (sci_ptr, 0, "No process specified.^/Usage: slp {process_specifier | -dbr dbr_value | -cpu TAG} {-bf | -lg}"); if dbr_sw then do; dbr = cv_oct_check_ (proc_arg, code); if code ^= 0 then do; call ssu_$abort_line (sci_ptr, error_table_$badopt, "DBR value not octal ""^a"".", proc_arg); end; end; else if cpu_sw then do; if procl >= 2 then goto bad_name; i = index (CPU_NAME, proc_arg); if i = 0 then do; bad_name: call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "CPU tag must be a thru h ""^a"".", proc_arg); end; cpu_name = proc_arg; end; else do; /* have a process indicator */ apte_offset, pid = 0; call determine_process_idx (apte_offset, pid, process_idx); end; if apte_offset > 0 then do; index_changed = "1"b; call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, lbound (fdump_process_table.array, 1)); call amu_$tc_data_get_dbr (amu_info_ptr, apte_offset, dbr); if dbr = -1 then do; call ioa_ ("APTE at ^o is empty", apte_offset); return; end; end; if pid > 0 then do; /* match on process-ids to get the process_idx */ pidbit = convert(pidbit, pid); hold_index = amu_info.process_idx; call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, hold_index); found = "0"b; do i = 0 to hbound (fdump_process_table.array, 1) while (^found); call amu_$fdump_mpt_change_idx (amu_info_ptr, i); Pproc = fdump_process_table.array(i).process_info_ptr; if Pproc->process_info.pid = pidbit then do; found = "1"b; process_idx = i; end; end; call amu_$fdump_mpt_revert_idx (amu_info_ptr); if ^(found) then call ssu_$abort_line (sci_ptr, 0, "Process with id ^a not found in dump.", proc_arg); end; PRINT_CURRENT: code = 0; call amu_$fdump_mpt_fill_proc_table (amu_info_ptr, dbr, process_idx, cpu_name, brief_sw, code); if code ^= 0 then do; if dbr_sw then code = amu_et_$dbr_not_found; call ssu_$abort_line (sci_ptr, code, " ^[""^a""^;^s^].", proc_ptr^= null(), proc_arg); end; return; %page; common_mc: proc; /* now we should know where to get the mc from and what parts the user wants so set up to get the data and then get it */ if ^arg_bits_def.dump then do; range = 48; data_buf_ptr = addr (mc_area); call get_data_ (data_buf_ptr, segno, first, range, code); end; /* now that we have the data get it printed */ call azm_display_mc_ (sci_ptr, amu_info_ptr, data_buf_ptr, arg_bits_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, ""); else if (arg_bits_def.set_ptr & arg_bits_def.mc_stored & ^arg_bits_def.dump) then do; temp_ptr = pointer (baseptr (segno), first); call ioa_ ("Setting Temporary pointers from ^p.", temp_ptr); t_pr_name = "prmc"; call amu_$definition_set_prn (amu_info_ptr, t_pr_name, segno, first, code); t_pr_name = "prs"; call amu_$definition_set_from (amu_info_ptr, t_pr_name, data_buf_ptr, code); t_pr_name = "pr6"; call amu_$definition_get_prn (amu_info_ptr, t_pr_name, temp_ptr, code); if cond_frame then first = first - 48; else do; segno = fixed (baseno (temp_ptr), 17); first = fixed (rel (temp_ptr), 18); end; t_pr_name = "prfr"; call amu_$definition_set_prn (amu_info_ptr, t_pr_name, segno, first, code); end; if arg_bits_def.dump then if arg_bits_def.set_ptr then call ioa_ ("^/Cannot set temporary pointers from the dump registers."); end common_mc; %page; dump_as_structure: proc(long_sw); dcl long_sw bit(1); amu_info.sci_ptr = sci_ptr; /* need this for amu_get_name_$for_structure */ display_size = sys_info$max_seg_size; copy_ptr = pointer(baseptr(segno), first); call get_data_ (data_buf_ptr, segno, first, display_size, code); if code ^= 0 then do; call ssu_$release_temp_segment (sci_ptr, data_buf_ptr); call ssu_$abort_line (sci_ptr, code, ""); end; call structure_ref_$parse ((struct_name), (""), unsubscripted_name, subscripts, n_subscripts, match_names, n_match_names, code); if (code ^= 0) then call ssu_$abort_line (sci_ptr, 0, "Syntax error in structure reference ^a.", struct_name); call structure_find_$search (unsubscripted_name, symbol_ptr, code); if (code ^= 0) then call ssu_$abort_line (sci_ptr, 0, "Cannot get library definition for ^a", unsubscripted_name); call display_data_$for_azm (null (), (^long_sw), match_names, n_match_names, amu_info_ptr, data_buf_ptr, display_size, copy_ptr, symbol_ptr, subscripts, n_subscripts, code); if (code ^= 0) then call ssu_$abort_line (sci_ptr, code, "^a", struct_name); end dump_as_structure; %page; determine_process_idx: proc(apte_offset, pid, pidx); dcl apte_offset fixed bin(18), pidx fixed bin, pid fixed bin(36), proc_idx fixed bin(35), code fixed bin(35); proc_idx = cv_dec_check_ (proc_arg, code); if code ^= 0 then do; call ssu_$abort_line (sci_ptr, error_table_$badopt, "Process indicator is invalid. ""^a"".", proc_arg); end; if proc_idx < 3000 then do; /* have a process index */ pidx = proc_idx; end; else if proc_idx > 777777 then do; /* octal process-id */ pid = cv_oct_check_ (proc_arg, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$badopt, "Process-id not octal ""^a"".", proc_arg); end; else do; /* must be an octal APTE offset */ apte_offset = cv_oct_check_ (proc_arg, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$badopt, "APTE offset not octal ""^a"".", proc_arg); end; end determine_process_idx; %page; dtc: proc (b) returns (char (24)); dcl b bit (36) parameter; dcl buf bit (72); dcl fbuf fixed (71); dcl date char (24); buf = "0"b; substr (buf, 21) = b; unspec (fbuf) = unspec (buf); call date_time_ (fbuf, date); return (date); end dtc; %page; get_data_: proc (data_ptr, seg, word, number, a_code); dcl data_ptr ptr; dcl seg fixed bin; dcl sidx fixed bin; dcl (word, number) fixed bin (18); dcl a_code fixed bin (35); a_code = 0; index_changed = "0"b; if azm_info.in_erf then do; if ^amu_$return_val_per_process (amu_info_ptr, seg) then do; index_changed = "1"b; call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, lbound (fdump_process_table.array, 1)); end; end; call amu_$do_translation (amu_info_ptr, seg, data_ptr, word, number, a_code); if index_changed = "1"b then do; do sidx = 1 to translation_table.n_entries while (seg ^= translation_table (sidx).segno); end; if translation_table.flags (sidx).replaced then return; else call amu_$fdump_mpt_revert_idx (amu_info_ptr); index_changed = "0"b; end; end get_data_; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_mc_pr_list: proc(); dcl i fixed bin; va_sw = "0"b; if argno = nargs then do; /* set the default */ arg_bits_def.prs = "1"b; goto END_PR; end; argno = argno + 1; do i = argno to nargs; call ssu_$arg_ptr (sci_ptr, i, argp, argl); if substr (arg, 1, 1) = "-" then do; if i = argno then /* set the default */ arg_bits_def.prs = "1"b; goto END_PR; end; else do; temp_num = cv_oct_check_ (arg, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "Invalid pointer reg specified ""^a"".", arg); if ^(temp_num < 0 | temp_num > 7) then arg_bits_def.pr (temp_num) = "1"b; else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "Invalid pointer reg specified < 0 | > 7 ""^a"".", arg); end; end; END_PR: argno = i - 1; /* reset argno */ return; end get_mc_pr_list; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_mc_reg_list: proc(); dcl i fixed bin; if argno = nargs then do; /* set the default */ arg_bits_def.regs = "1"b; goto END_REG; end; argno = argno + 1; do i = argno to nargs; call ssu_$arg_ptr (sci_ptr, i, argp, argl); if substr (arg, 1, 1) = "-" then do; if i = argno then /* set the default */ arg_bits_def.regs = "1"b; goto END_REG; end; else if substr (arg, 1, 1) = "x" then do; temp_num = cv_oct_check_ (substr (arg, 2, 1), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "bad x reg ""^a"".", arg); arg_bits_def.xreg (temp_num) = "1"b; end; else if arg = "a" then arg_bits_def.areg = "1"b; else if arg = "q" then arg_bits_def.qreg = "1"b; else if arg = "all" then arg_bits_def.regs = "1"b; end; END_REG: argno = i - 1; /* reset argno */ return; end get_mc_reg_list; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_mc_specifiers: proc(); dcl i fixed bin; if argno = nargs then do; /* set the defaults */ if pds_sw then mcp_pgflt_sw, mcp_fim_sw, mcp_sig_sw = "1"b; else mcpr_int_sw, mcpr_fim_sw, mcpr_systroub_sw = "1"b; return; end; argno = argno + 1; do i = argno to nargs; call ssu_$arg_ptr (sci_ptr, i, argp, argl); if substr (arg, 1, 1) = "-" then do; if i = argno then do; /* set the default "all" */ if pds_sw then mcp_pgflt_sw, mcp_fim_sw, mcp_sig_sw = "1"b; else mcpr_int_sw, mcpr_fim_sw, mcpr_systroub_sw = "1"b; end; goto END_SPECS; end; else if arg = "all" then do; if pds_sw then mcp_pgflt_sw, mcp_fim_sw, mcp_sig_sw = "1"b; else mcpr_int_sw, mcpr_fim_sw, mcpr_systroub_sw = "1"b; end; else do; if pds_sw then do; if va_sw then if index (arg, va.va_string) > 0 then va_sw = "0"b; if arg = "pgf" | arg = "page_fault" | arg = "page_fault_data" then mcp_pgflt_sw = "1"b; else if arg = "fim" | arg = "fim_data" then mcp_fim_sw = "1"b; else if arg = "sig" | arg = "signal" | arg = "signaller" | arg = "signal_data" then mcp_sig_sw = "1"b; else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, """^a"".", arg); end; else if prds_sw then do; if va_sw then if index (arg, va.va_string) > 0 then va_sw = "0"b; if arg = "fim" | arg = "fim_data" then mcpr_fim_sw = "1"b; else if arg = "int" | arg = "interrupt" | arg = "interrupt_data" then mcpr_int_sw = "1"b; else if arg = "sys" | arg = "system_trouble" | arg = "sys_trouble_data" then mcpr_systroub_sw = "1"b; else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, """^a"".", arg); end; else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, """^a"".", arg); end; end; /* arg processing loop */ END_SPECS: argno = i - 1; /* reset argno */ return; end get_mc_specifiers; %page; get_new_trans: proc (segno, code); /* get a translation for the seg and place / replace it in the translation table */ dcl code fixed bin(35); dcl segno fixed bin; dcl 1 temp_trans like translation; dcl temp_proc_hold fixed bin; translation_ptr = addr (temp_trans); if amu_info.type = FDUMP_PROCESS_TYPE then do; if ^amu_$return_val_per_process (amu_info_ptr, segno) then do; /* could be stack for logger */ temp_proc_hold = amu_info.process_idx; call amu_$fdump_mpt_change_idx (amu_info_ptr, 0); call amu_$fdump_translate_to_temp_seg (amu_info_ptr, baseptr (segno), translation_ptr, code); call amu_$fdump_mpt_change_idx (amu_info_ptr, temp_proc_hold); end; else do; call amu_$fdump_translate_to_temp_seg (amu_info_ptr, baseptr (segno), translation_ptr, code); end; end; else if amu_info.type = SAVED_PROC_TYPE then do; code = amu_et_$no_translation; return; end; else do; code = amu_et_$not_implemented; return; end; if code ^= 0 then return; call amu_$translate_force_add (amu_info_ptr, translation_ptr, segno, code); if code ^= 0 then return; end get_new_trans; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_next_arg: proc(Arg_expected, ap1, al1); /* This guy gets the next argument from the argument string, complaining if it's not there */ dcl Arg_expected char(*); dcl (ap1 ptr, al1 fixed bin(21)); if (argno + 1) > nargs then do; call ssu_$abort_line(sci_ptr, error_table_$noarg, "A ^a expected after ^a.", Arg_expected, arg); return; end; argno = argno + 1; call ssu_$arg_ptr (sci_ptr, argno, ap1, al1); end get_next_arg; %page; get_stack: proc(stack_no, code); dcl stack_no fixed bin(17); dcl code fixed bin(35); code = 0; call amu_$translate_get (amu_info_ptr, stack_no, translation_ptr, code); if translation_ptr = null then do; /* if null then no trans */ if code = amu_et_$invalid_segno then do; /* not valid segno */ call amu_$error_for_caller (amu_info_ptr, code, ssu_$get_subsystem_and_request_name, "Cannot get segment ^o.", stack_no); return; end; else do; /* OK now translate it into a temp seg */ call get_new_trans (stack_no, code); if code ^= 0 then do; call amu_$error_for_caller (amu_info_ptr, code, ssu_$get_subsystem_and_request_name, "Unable to translate segment ^o.", stack_no); return; end; end; end; else do; /* if translated see if it is in a temp seg */ if ^translation.flags.in_temp_seg & ^translation.flags.in_perm_seg then do; /* is not in a temp seg so retranslate it */ call get_new_trans(stack_no, code); if code ^= 0 then do; call amu_$error_for_caller (amu_info_ptr, code, ssu_$get_subsystem_and_request_name, "Unable to translate segment ^o.", stack_no); return; end; end; end; sb = translation.part1.ptr; if ^thread_ptr_val (stack_header.stack_begin_ptr, stack_no) then code = amu_et_$not_stack_seg; else if ^thread_ptr_val (stack_header.stack_end_ptr, stack_no) then code = amu_et_$not_stack_seg; end get_stack; %page; hunt_for_code: proc (seg, word, number); dcl seg fixed bin; dcl (word, number) fixed bin (18); index_changed = "0"b; if azm_info.in_erf then do; if ^amu_$return_val_per_process (amu_info_ptr, seg) then do; index_changed = "1"b; call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, lbound (fdump_process_table.array, 1)); end; end; call amu_$do_translation_hunt (amu_info_ptr, seg, data_buf_ptr, word, number, code); if index_changed = "1"b then do; call amu_$fdump_mpt_revert_idx (amu_info_ptr); index_changed = "0"b; end; end hunt_for_code; %page; list_by_state: proc(); dcl state_found bit(1); state_found = "0"b; hold_index = amu_info.process_idx; call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, hold_index); do i = 0 to hbound (fdump_process_table.array, 1); call amu_$fdump_mpt_change_idx (amu_info_ptr, i); Pproc = fdump_process_table.array(i).process_info_ptr; if list_state(Pproc->process_info.state) then do; state_found = "1"b; tally_states(Pproc->process_info.state) = tally_states(Pproc->process_info.state) + 1; if ^totals_only then do; if af_sw then call amu_$fdump_mpt_current_process_af (amu_info_ptr, rv_ptr, rv_lth); else call amu_$fdump_mpt_current_process (amu_info_ptr); end; end; end; if ^state_found then do; if af_sw then rv_str = ""; else if ^ct_sw then call ssu_$abort_line(sci_ptr, 0, "No processes in the dump met state criteria specified."); end; if ct_sw then call print_totals(); call amu_$fdump_mpt_revert_idx (amu_info_ptr); end list_by_state; %page; mc_by_keyword: proc(); if mcp_pgflt_sw then do; temp_ptr = amu_$definition_ptr (amu_info_ptr, "pds", "page_fault_data", code); segno = fixed (baseno (temp_ptr), 17); first = fixed (rel (temp_ptr), 18); call ioa_ ("^/Machine conditions from pds$page_fault_data:"); call common_mc(); end; if mcp_fim_sw then do; temp_ptr = amu_$definition_ptr (amu_info_ptr, "pds", "fim_data", code); segno = fixed (baseno (temp_ptr), 17); first = fixed (rel (temp_ptr), 18); call ioa_ ("^/Machine conditions from pds$fim_data:"); call common_mc(); end; if mcp_sig_sw then do; temp_ptr = amu_$definition_ptr (amu_info_ptr, "pds", "signal_data", code); segno = fixed (baseno (temp_ptr), 17); first = fixed (rel (temp_ptr), 18); call ioa_ ("^/Machine conditions from pds$signal_data:"); call common_mc(); end; if mcpr_int_sw then do; temp_ptr = amu_$definition_ptr (amu_info_ptr, "prds", "interrupt_data", code); segno = fixed (baseno (temp_ptr), 17); first = fixed (rel (temp_ptr), 18); call ioa_ ("^/Machine conditions from prds$interrupt_data:"); call common_mc(); end; if mcpr_fim_sw then do; temp_ptr = amu_$definition_ptr (amu_info_ptr, "prds", "fim_data", code); segno = fixed (baseno (temp_ptr), 17); first = fixed (rel (temp_ptr), 18); call ioa_ ("^/Machine conditions from prds$fim_data:"); call common_mc(); end; if mcpr_systroub_sw then do; temp_ptr = amu_$definition_ptr (amu_info_ptr, "prds", "sys_trouble_data", code); segno = fixed (baseno (temp_ptr), 17); first = fixed (rel (temp_ptr), 18); call ioa_ ("^/Machine conditions from prds$sys_trouble_data:"); call common_mc(); end; end mc_by_keyword; %page; print_totals: proc(); dcl i fixed bin; if af_sw then rv_str = ""; if af_sw & totals_only then rv_str = ltrim(char(fdump_process_table.size + 1)); else do; do i = 1 to hbound(list_state,1); if list_state(i) then do; if af_sw then rv_str = rv_str || " " || ltrim(char(tally_states(i))); else call ioa_$nnl("^/Processes ^a =^21t^d.", process_st(i), tally_states(i)); end; end; if totals_only then call ioa_$nnl("^/Total processes =^21t^d.", fdump_process_table.size + 1); end; end print_totals; %page; process_common_args: proc(); ct_sw, cur_sw, totals_only, proc_sw, all_sw, brief_sw = "0"b; process_idx = -1; pid, apte_offset = 0; list_state(*) = "0"b; tally_states(*) = 0; if nargs = 0 then do; list_state(*) = "1"b; end; do argno = 1 to nargs; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if substr (arg, 1, 1) ^= "-" then do; procl = argl; proc_ptr = argp; proc_arg = arg; proc_sw = "1"b; end; else if arg = "-a" | arg = "-all" then do; all_sw, list_state(*) = "1"b; end; else if arg = "-ct" | arg = "-count" then do; ct_sw = "1"b; end; else if arg = "-cur" | arg = "-current" then do; cur_sw = "1"b; end; else if arg = "-blk" | arg = "-blocked" then do; list_state(BLK) = "1"b; end; else if arg = "-ptl" | arg = "-page_table_lock" then do; list_state(PTL) = "1"b; end; else if arg = "-rdy" | arg = "-ready" then do; list_state(RDY) = "1"b; end; else if arg = "-run" then do; list_state(RUN) = "1"b; end; else if arg = "-stop" | arg = "-stopped" then do; list_state(STP) = "1"b; end; else if arg = "-wait" then do; list_state(WAIT) = "1"b; end; else do; call ssu_$abort_line (sci_ptr, error_table_$badopt, "Not a valid arg ""^a"".", arg); end; end; if (proc_sw | cur_sw) & nargs >1 then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^[process_specifier^;-current^] and -ctl_args", proc_sw); if ct_sw then if nargs = 1 then do; totals_only = "1"b; list_state(*) = "1"b; end; end process_common_args; %page; set_up: proc; sci_ptr = P_sci_ptr; azm_info_ptr = P_azm_info_ptr; amu_info_ptr = azm_info.aip; call ssu_$return_arg (sci_ptr, nargs, af_sw, rv_ptr, rv_lth); if ^af_sw then call ssu_$arg_count (sci_ptr, nargs, af_sw); end set_up; %page; thread_ptr_val: proc (vptr, segno) returns (bit (1)); dcl vptr ptr; dcl segno fixed bin; dcl ret_bit bit(1); dcl any_other condition; ret_bit="0"b; on condition (any_other) begin; goto RET_VAL; end; if addr (vptr) -> its.its_mod = ITS_MODIFIER then do; if segno = fixed (baseno (vptr), 17) then ret_bit= "1"b; else ret_bit= "0"b; end; else ret_bit ="0"b; RET_VAL: return(ret_bit); end thread_ptr_val; %page; trans_selected: proc () returns (bit (1)); return (^(amu_info_ptr = null())); end trans_selected; %page; va_arg: proc(a_pos) returns(bit(1)); dcl a_pos fixed bin; dcl i fixed bin; dcl arg_positions (3) aligned based (Ppos); /*dcl 1 arg_positions aligned based (Ppos), 2 indx (3) fixed bin; */ dcl Ppos ptr; Ppos = addr(va.va_position); do i = 1 to hbound(arg_positions,1); if a_pos = arg_positions(i) then return("1"b); end; return("0"b); end va_arg; %page (1); vput: proc (x); dcl x char (*) parameter; if x = "FLUSH" | length (vs) > ll - 10 then do; if vs = "" then call ioa_ ("No Flags."); else call ioa_ ("Flags: ^a", vs); vs = ""; end; vs = vs || x; return; end vput; %page;%include add_type; %page;%include amu_fdump_info; %page;%include amu_hardcore_info; %page;%include amu_info; %page;%include amu_mc; %page;%include amu_process_info; %page;%include amu_translation; %page;%include aste; %page;%include azm_info; %page;%include azm_va_args; %page;%include bos_dump; %page;%include cmp; %page;%include dump_segment_format; %page;%include its; %page;%include mc; %page;%include ptw; %page;%include pvt; %page;%include pvte; %page;%include sdw; %page;%include signaller_stack; %page;%include sst; %page;%include stack_frame; %page;%include stack_header; %page;%include unpaged_page_tables; end azm_requests_1_;  azm_requests_2_.pl1 07/12/88 1443.5rew 07/12/88 1431.6 293598 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-07-09,Leatherman), approve(87-07-09,MCR7746), audit(87-07-16,Fawcett), install(87-07-28,MR12.1-1049): Change references from "No translation selected" to "No dump selected" for better understanding. 2) change(87-08-14,Parisek), approve(87-08-14,MCR7861), audit(88-07-08,Farley), install(88-07-12,MR12.2-1055): Correct bug in setting PTW pointer when given page address is greater than zero. END HISTORY COMMENTS */ azm_requests_2_: proc (); return; /* not an entrypoint */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */ /* Assorted requests for analyze_multics. */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* 0) Created: 06/25/83 by B. Braun from the original azm_misc_requests_ into smaller */ /* modules. This contains azm requests associative_memory, verify_associative_memory, */ /* scus, search, segment_name, segment_number, replace, value, set, clock, error_code, */ /* quit, self_identify (.), absolute_address. */ /* 1) Modified 12/8/83 by B. Braun to add "-a" syn for "-all" in value request and correct*/ /* usage message. Correct "number foo" to return "Segment not found." */ /* 2) Modified July 84 by B. Braun to add knowledge of unpaged_page_tables to absadr. */ /* 3) Modified Sept 84 by B. Braun to add knowledge of int_unpaged_page_tables to absadr. */ /* 4) Modified Nov 84 by B. Braun to change the number active request to return only the */ /* segment number and not the offset. */ /* 5) Modified 21 Nov 84 by B. Braun to correct "replace" request to use expand_pathname_ */ /* 6) Modified 10 Jan 85 by BLB to correct the ioa_$rsnnl call in the name active request.*/ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl ( P_sci_ptr pointer, P_azm_info_ptr pointer ) parameter; /* Automatic */ dcl af_sw bit (1) aligned; dcl am_from_prds bit (1); dcl amptw_pageno fixed bin; dcl amsdw_segno fixed bin; dcl axp ptr init (null); dcl argl fixed bin (21); dcl argno fixed bin; dcl argp pointer; dcl axstring char (7) init (""); dcl brief_sw bit (1) init ("0"b); dcl check_args fixed bin; dcl code fixed bin (35); dcl configp ptr init (null); dcl cur_erf bit (1) init ("0"b); dcl del_cur_erf bit (1) init ("0"b); dcl del_erf bit (1) init ("0"b); dcl dir_name char (168); dcl dir_sw bit (1) init ("0"b); dcl do_ptws bit (1); dcl do_sdws bit (1); dcl dsegp ptr init (null); dcl erfs_found bit (1) init ("0"b); dcl expand_ptr_sw bit (1) init ("0"b); dcl expand_sw bit (1) init ("0"b); /* "1"b = expand syserr binary data */ dcl first fixed bin (18); dcl first_erf bit (1) init ("0"b); dcl first_value_set bit (1) init ("0"b); dcl forward_search bit (1) init ("0"b); dcl frame_entry bit (1) init ("0"b); dcl 1 hard_ptr_space like hardcore_cur; dcl hdr_printed bit (1) init ("0"b); dcl ignore fixed bin; dcl i fixed bin; /* for iterations */ dcl last fixed bin init (0); dcl last_erf bit (1) init ("0"b); dcl list_erfs bit (1) init ("0"b); dcl ll fixed bin init (0); dcl ln fixed bin init (0); dcl match_str char (256) var init (""); /* the syserr string to match on */ dcl nargs fixed bin; dcl namep ptr; dcl next_erf bit (1) init ("0"b); dcl offset fixed bin (18); dcl only_full_ams bit (1); dcl page fixed bin (24); dcl prev_erf bit (1) init ("0"b); dcl print_all_trans bit (1) init ("0"b); dcl pts fixed bin (24); dcl range fixed bin (18); dcl range_value_set bit (1) init ("0"b); dcl raw_syserr_data bit (1) init ("0"b); /* "1"b = print it in octal */ dcl real_address fixed bin (35); dcl ret_str char (168) var init (""); dcl rv_lth fixed bin (21); dcl rv_ptr ptr; dcl sci_ptr pointer; /* assorted info pointers */ dcl segln fixed bin (35) init (0); dcl search_string char (12); dcl segname char(32); dcl segno fixed bin; dcl segno_sw bit(1); dcl slog_code fixed bin init (3); /* the syserr_code, default to =< 3 */ dcl start_configp ptr init (null); dcl struct_sw bit (1) init ("0"b); dcl t_amu_info_ptr ptr; dcl t_pr_name char (4); dcl t_seg_name char (32); dcl temp_ptr ptr; dcl temp_str char (24) var init (""); dcl tname char(256) var; dcl vs char (99) varying; dcl why_erf bit (1) init ("0"b); dcl word fixed bin (24); %page; /* Based */ dcl arg char (argl) based (argp); dcl rs char (rv_lth) varying based (rv_ptr); /* Constants */ /* Builtins */ dcl (addr, addrel, baseptr, char, convert, divide, fixed, hbound, ltrim, null, pointer, reverse, rtrim, search, substr, index, mod, ptr) builtin; /* Conditions */ %page; /* External Entries */ dcl amu_$current_deadproc entry(ptr); dcl amu_$definition_get_prn entry (ptr, char (*), ptr, fixed bin (35)); dcl amu_$definition_set_prn entry (ptr, char (*), fixed bin, fixed bin (18), fixed bin (35)); dcl amu_$do_translation_hunt_ptr entry (ptr, ptr, ptr, fixed bin (35)); dcl amu_$fdump_mgr_cur_erf entry (ptr); dcl amu_$fdump_mpt_current_process entry (ptr); dcl amu_$get_name_no_comp entry (ptr, ptr) returns (char (*)); dcl amu_$get_name entry (ptr, ptr) returns (char (*)); dcl amu_$get_va_args entry (ptr, ptr, ptr, fixed bin, ptr); dcl amu_$get_va_args_given_start entry (ptr, ptr, ptr, fixed bin, fixed bin, ptr); dcl amu_$hardcore_info_set_cur_ptrs entry (ptr, ptr); dcl amu_$replace_trans entry (ptr, char (168), char (32), fixed bin, fixed bin (35)); dcl amu_$resolve_virtual_addr entry (ptr, ptr, char(*), fixed bin, fixed bin(18), fixed bin (35)); dcl amu_$search_seg entry (ptr, ptr, fixed bin(21), fixed bin, fixed bin (18), fixed bin (18), char (12), fixed bin (35)); dcl amu_$terminate_translation entry (pointer); dcl azm_display_am_ entry (ptr, ptr, bit (1), bit (1), bit (1), bit (1), fixed bin, fixed bin, fixed bin (35)); dcl azm_dump_mem_$mem_config entry (ptr, fixed bin (35)); dcl azm_find_mem_box_ entry (ptr, fixed bin (35), fixed bin, fixed bin (18), fixed bin (35)); dcl azm_verify_dump_ams_ entry (ptr, bit (1), bit (1), fixed bin (35)); dcl azm_verify_dump_ams_$af entry (ptr, bit (1), bit (1), fixed bin (35)) returns (bit (1)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl ( ioa_, ioa_$rsnnl ) entry options (variable); dcl ssu_$abort_line entry options (variable); dcl ssu_$abort_subsystem entry options (variable); dcl ssu_$add_request_table entry (ptr, ptr, fixed bin, fixed bin (35)); dcl ssu_$arg_count entry (pointer, fixed bin, bit (1) aligned); dcl ssu_$arg_ptr entry (pointer, fixed bin, pointer, fixed bin (21)); dcl ssu_$get_abbrev_info entry (ptr, ptr, ptr, bit(1) aligned); dcl ssu_$get_invocation_count entry (ptr, fixed bin, fixed bin); dcl ssu_$get_subsystem_name entry (ptr) returns(char(32)); dcl ssu_$get_subsystem_version entry (ptr) returns(char(32)); dcl ssu_$return_arg entry (ptr, fixed bin, bit (1) aligned, ptr, fixed bin (21)); /* error codes */ dcl amu_et_$no_va_specified fixed bin (35) external static; dcl error_table_$badopt fixed bin (35) external static; dcl error_table_$wrong_no_of_args fixed bin (35) external static; dcl error_table_$segknown fixed bin (35) external static; dcl error_table_$noarg fixed bin (35) external static; dcl error_table_$bad_arg fixed bin (35) external static; dcl error_table_$inconsistent fixed bin (35) external static; dcl error_table_$too_many_args fixed bin (35) external static; %page; /*****************************************************************************/ azm_requests_2_$absolute_address: entry (P_sci_ptr, P_azm_info_ptr); dcl sdw_add fixed bin(26); dcl relative_offset fixed bin(26); dcl bd_sdw fixed bin(24); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); if nargs = 0 then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage: absaddr virtual-address"); if nargs > 2 then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "^/Usage: absaddr virtual-address"); /* process arguments */ /* init va_args */ va_args_ptr = addr(va_args); va.segno, va.offset, va.offset_modifier, va.va_position, va.ecode = 0; va.va_switches = "0"b; va.error_msg, va.va_string = ""; va.resolved_va = null(); call ssu_$arg_ptr (sci_ptr, 1, argp, argl); call amu_$get_va_args(sci_ptr, amu_info_ptr, argp, nargs, va_args_ptr); if va.ecode ^= 0 | va.error_msg ^="" then do; call ssu_$abort_line (sci_ptr, va.ecode, "^a", va.error_msg); end; va.range_idx = 0; /* A range is not valid for mc request */ do argno = 1 to nargs; /* looping to catch any invalid args */ call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if ^va_arg(argno) then do; if substr(arg,1,1) = "-" then code = error_table_$badopt; else code = error_table_$bad_arg; call ssu_$abort_line(sci_ptr, code, " ^a", arg); end; end; /* arg processing */ segno = va.segno; first = va.offset; vs = ""; hardcore_cur_ptr = addr (hard_ptr_space); call amu_$hardcore_info_set_cur_ptrs (amu_info_ptr, hardcore_cur_ptr); if hardcore_cur.sstp = null () then call ssu_$abort_line (sci_ptr, 0, "No sst in the fdump."); sstp = hardcore_cur.sstp; /* get a pointer to the SDW for the segment */ call amu_$do_translation_hunt_ptr (amu_info_ptr, pointer (baseptr (hardcore_info.dseg), (2 * va.segno)), sdwp, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Cannot get pointer to SDW for ^o., va.segno"); if index (amu_$get_name (amu_info_ptr, addrel (baseptr (va.segno), va.offset)), "OUT-OF-BOUNDS") ^= 0 then go to ABSADR_OOSB; if sdw.unpaged /* see if the segment is paged */ then if sdw.df /* segment fault? */ then do; /* nope, got the address */ real_address = fixed (sdw.add, 24) + first; if af_sw then do; call ioa_$rsnnl ("^8o", vs, ignore, real_address); return; end; call azm_find_mem_box_ (amu_info_ptr, real_address, segno, first, code); return; end; else do; /* segment not active */ call ioa_$rsnnl ("Segment ^a (^o) is unpaged and faulted.", vs, ignore, amu_$get_name (amu_info_ptr, addrel (baseptr (va.segno), va.offset)), va.segno); if af_sw then do; ABSADR_ABT_AF: call ssu_$abort_line (sci_ptr, 0, "^a", vs); end; go to ABS_ADDR_RET; end; upt_ptr = hardcore_cur.uptp; sdw_add = fixed(sdw.add,26); bd_sdw = fixed (sdw.bound, 24) * 16; pts = divide (bd_sdw, 1024, 18); word = mod (first, 1024); /* get word within page */ page = divide (first, 1024, 17, 0); /* get PTW index */ /* get a pointer to page table */ if upt_ptr = null() then do; ptp = ptr (hardcore_cur.sstp, fixed (sdw.add, 24) - fixed (sst.ptwbase, 18)); astep = addrel (ptp, -sst.astsize); /* get ptr to ASTE */ pts = sst.pts (fixed (aste.ptsi, 3)); if page >= pts then do; ABSADR_OOSB: call ioa_$rsnnl ("Offset ^o not found in segment ^o.", vs, ignore, first, segno); if af_sw then go to ABSADR_ABT_AF; go to ABS_ADDR_RET; end; else ptp = addrel (ptp, page); /* get ptr to PTW */ end; else if (sdw_add > upt.upt_absloc & sdw_add < upt.upt_last_loc) then do; relative_offset = sdw_add - upt.upt_absloc; ptp = addrel(upt_ptr, relative_offset); end; else if (sdw_add > upt.iupt_absloc & sdw_add < upt.iupt_last_loc) then do; relative_offset = sdw_add - upt.iupt_absloc; ptp = addrel(upt_ptr, relative_offset); end; else do; relative_offset = sdw_add - upt.sst_absloc; ptp = addrel(sstp, relative_offset); end; if page > 0 then ptp = addrel (ptp, page); /* get ptr to PTW */ if ptw.df /* is page in memory? */ then do; /* yes, it's there */ real_address = (fixed (ptw.add, 18) * 64) + word; if af_sw then call ioa_$rsnnl ("^8o", rs, ignore, real_address); else do; call azm_find_mem_box_ (amu_info_ptr, real_address, segno, first, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/Locating memory for ^o, real address ^8o.", pointer (baseptr (segno), first), real_address); end; end; else do; call ioa_$rsnnl ("Page #^o of ^a (seg #^o) is not in main memory.", vs, ignore, page, amu_$get_name (amu_info_ptr, addrel (baseptr (segno), first)), segno); if af_sw then go to ABSADR_ABT_AF; end; ABS_ADDR_RET: if ^af_sw then call ioa_ ("^a", vs); return; %page; /*****************************************************************************/ azm_requests_2_$add_request_table: entry (P_sci_ptr, P_azm_info_ptr); call set_up; if nargs = 0 then call ssu_$abort_line(sci_ptr, error_table_$noarg, "^/Usage: arqt PATHNAME"); if nargs ^= 1 then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "Only one pathname allowed."); call ssu_$arg_ptr (sci_ptr, 1, argp, argl); call expand_pathname_ (arg, dir_name, t_seg_name, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Expanding pathname."); call hcs_$initiate (dir_name, t_seg_name, "", 0, 0, temp_ptr, code); if code ^= 0 then if code ^= error_table_$segknown then call ssu_$abort_line (sci_ptr, code, "Initiating ""^a"".", rtrim (dir_name) || ">" || rtrim (t_seg_name)); call ssu_$add_request_table (sci_ptr, temp_ptr, 9999, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Adding request table."); return; %page; /*****************************************************************************/ azm_requests_2_$associative_memory: entry (P_sci_ptr, P_azm_info_ptr); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); code = 0; am_from_prds = "0"b; do_sdws, do_ptws = "1"b; /* default to both */ amsdw_segno, amptw_pageno = -1; /* default to all */ only_full_ams = "1"b; do argno = 1 to nargs; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if arg = "-dump" then am_from_prds = "0"b; else if arg = "-prds" then am_from_prds = "1"b; else if arg = "-all" | arg = "-a" then only_full_ams = "0"b; else if arg = "-ptw" then do; do_ptws = "1"b; do_sdws = "0"b; end; else if arg = "-sdw" then do; do_sdws = "1"b; do_ptws = "0"b; end; else if arg = "-segno" then do; call get_next_arg("SEGNO", argp, argl); amsdw_segno = cv_oct_check_ (arg, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "-segno requires an OCTAL value ""^a"".", arg); end; else if arg = "-pageno" then do; call get_next_arg("PAGENO", argp, argl); amptw_pageno = cv_oct_check_ (arg, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "-pageno requires an OCTAL value ""^a"".", arg); end; else call ssu_$abort_line (sci_ptr, error_table_$badopt, "Usage: am {-ctl_args}"); end; if ^do_ptws & amptw_pageno ^= -1 then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^/Cannot select a pageno without displaying PTWAM."); if amptw_pageno ^= -1 & amsdw_segno = -1 then do_sdws = "0"b; call azm_display_am_ (sci_ptr, amu_info_ptr, am_from_prds, do_sdws, do_ptws, only_full_ams, amsdw_segno, amptw_pageno, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, ""); return; %page; /*****************************************************************************/ azm_requests_2_$clock: entry (P_sci_ptr, P_azm_info_ptr); sci_ptr = P_sci_ptr; call ssu_$abort_line (sci_ptr, 0, "This request has not been implemented yet."); return; %page; /*****************************************************************************/ azm_requests_2_$delete_request_table: entry (P_sci_ptr, P_azm_info_ptr); /* this entrypoint is here only until ssu_ has its own standard delete_request_table request. 08/09/83 B. Braun */ sci_ptr = P_sci_ptr; call ssu_$abort_line (sci_ptr, 0, "This request has not been implemented yet."); return; %page; /*****************************************************************************/ azm_requests_2_$error_code: entry (P_sci_ptr, P_azm_info_ptr); sci_ptr = P_sci_ptr; call ssu_$abort_line (sci_ptr, 0, "This request has not been implemented yet."); return; %page; /*****************************************************************************/ azm_requests_2_$list_request_table: entry (P_sci_ptr, P_azm_info_ptr); /* this entrypoint is here only until ssu_ has its own standard list_request_table request. 08/09/83 B. Braun */ sci_ptr = P_sci_ptr; call ssu_$abort_line (sci_ptr, 0, "This request has not been implemented yet."); return; %page; /*****************************************************************************/ azm_requests_2_$name: entry (P_sci_ptr, P_azm_info_ptr); segno_sw = "0"b; goto SEGMENT_COMMON; /*****************************************************************************/ azm_requests_2_$number: entry (P_sci_ptr, P_azm_info_ptr); segno_sw = "1"b; SEGMENT_COMMON: call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); code = 0; if nargs = 0 then code = error_table_$noarg; else if nargs > 2 then code = error_table_$too_many_args; if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/Usage: ^[segno ^;name ^] | ", segno_sw); /* init va_args */ va_args_ptr = addr(va_args); va.range = 1; va.segno, va.offset, va.offset_modifier, va.va_position, va.ecode = 0; va.va_switches = "0"b; va.error_msg, va.va_string = ""; va.resolved_va = null(); call ssu_$arg_ptr (sci_ptr, 1, argp, argl); call amu_$get_va_args(sci_ptr, amu_info_ptr, argp, nargs, va_args_ptr); if va.ecode = amu_et_$no_va_specified then call ssu_$abort_line (sci_ptr, 0, "Segment ^[number^;name^] is not known^[ ""^a""^;^s^].", segno_sw, (va.va_string ^= ""), va.va_string); if va.ecode ^= 0 | va.error_msg ^="" then do; call ssu_$abort_line (sci_ptr, va.ecode, "^[^a^s^;^s^a^]", va.error_msg = "", va.va_string, va.error_msg); end; do argno = 1 to nargs; /* check for illegal args */ call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if ^va_arg(argno) then do; /* must be an error */ if substr(arg,1,1) = "-" then code = error_table_$badopt; else code = error_table_$bad_arg; call ssu_$abort_line(sci_ptr, code, " ^a", arg); end; end; /* processing loop */ if segno_sw then do; if ^af_sw then call ioa_ ("^a = Segno ^o|^o.", va.va_string, va.segno, va.offset); else call ioa_$rsnnl ("^o", rs, ignore, va.segno); /* dont return offset */ end; else do; /* called by name request */ namep = addrel (baseptr (va.segno), va.offset); if ^af_sw then call ioa_ ("^p = ^a", namep, amu_$get_name (amu_info_ptr, namep)); else do; /* active request case */ tname = amu_$get_name_no_comp (amu_info_ptr, baseptr (va.segno)); i = index(tname, ">"); if i > 0 then tname = reverse(substr(reverse(tname), 1, i-1)); call ioa_$rsnnl ("^a", rs, ignore, rtrim(tname)); end; end; return; %page; /*****************************************************************************/ azm_requests_2_$quit: entry (P_sci_ptr, P_azm_info_ptr); /* Leave the subsystem, and clean up. All cleaning up is actually done by the command, so this procedure does hardly anything at all. */ call set_up; /* start with the last in the chain amu_info_chain should be the last created */ if amu_info_ptr ^= null then do; t_amu_info_ptr = amu_info_ptr; /* now find the last amu_info in chain */ do while (t_amu_info_ptr -> amu_info.chain.next ^= null); t_amu_info_ptr = t_amu_info_ptr -> amu_info.chain.next; end; amu_info_ptr = t_amu_info_ptr; do while (amu_info_ptr ^= null); /* amu_$terminate_translation should reset the amu_info_chain */ call amu_$terminate_translation (amu_info_ptr); /* and set amu_info_ptr to that value */ end; end; azm_info.aip = amu_info_ptr; call ssu_$abort_subsystem (sci_ptr, 0); return; /* just in case */ %page; /*****************************************************************************/ azm_requests_2_$replace: entry (P_sci_ptr, P_azm_info_ptr); call set_up(); if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); if nargs ^= 2 then call ssu_$abort_line (sci_ptr, error_table_$wrong_no_of_args,"^/Usage: rp segno/name PATH."); dir_name = " "; segname =""; t_seg_name = " "; code = 0; argno = 2; /* process PATH first */ call ssu_$arg_ptr (sci_ptr, argno, argp, argl); call expand_pathname_ (arg, dir_name, t_seg_name, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Expanding pathname. ^a", arg); argno = 1; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); segno = cv_oct_check_ (arg, code); if code ^= 0 then do; /* Assume user specified seg name not number */ segname = arg; /* translate segname to a segno */ call amu_$resolve_virtual_addr (sci_ptr, amu_info_ptr, segname, segno, offset, code); if code ^= 0 then call ssu_$abort_line(sci_ptr, code, " ^a", segname); end; if index(t_seg_name, "=") > 0 then do; if segname = "" then t_seg_name = convert(t_seg_name, segno); else t_seg_name = segname; end; call amu_$replace_trans (amu_info_ptr, dir_name, t_seg_name, segno, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^/dir: ^a ^/entry: ^a", dir_name, t_seg_name); return; %page; /*****************************************************************************/ azm_requests_2_$scus: entry (P_sci_ptr, P_azm_info_ptr); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); code = 0; if nargs > 0 then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "^/Usage: scus"); call azm_dump_mem_$mem_config (amu_info_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, ""); return; %page; /*****************************************************************************/ azm_requests_2_$search: entry (P_sci_ptr, P_azm_info_ptr); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); if nargs <= 1 then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage: search {range} "); else if nargs > 4 then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "^/Usage: search {range} "); /* init va_args */ va_args_ptr = addr(va_args); va.range = 0; /* this sets the default to the whole segment */ va.segno, va.offset, va.offset_modifier, va.va_position, va.ecode = 0; va.va_switches = "0"b; va.error_msg, va.va_string = ""; va.resolved_va = null(); call ssu_$arg_ptr (sci_ptr, 1, argp, argl); if nargs = 2 then check_args = 1; /* NO range specified, don't check for it */ else check_args = nargs-1; /* Don't pass the search_string, it confuses get_va_args */ call amu_$get_va_args(sci_ptr, amu_info_ptr, argp, check_args, va_args_ptr); if va.ecode ^= 0 | va.error_msg ^="" then do; call ssu_$abort_line (sci_ptr, va.ecode, "^a", va.error_msg); end; argno = 1; code = 0; search_string = ""; do argno = argno to nargs; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if ^va_arg(argno) then do; /* assume its the search string */ if argl ^= 12 then call ssu_$abort_line (sci_ptr, 0, "SEARCH_STRING must be 12 characters."); search_string = arg; end; end; /* processing loop */ code = search (search_string, "0123457"); if code = 0 then call ssu_$abort_line (sci_ptr, 0, "SEARCH_STRING must contain an octal value to search for ""^a"".", search_string); code = search (search_string, "89"); if code ^= 0 then call ssu_$abort_line (ssu_$abort_line, 0, "SEARCH_STRING cannot have decimal number ""^a"".", substr (search_string, code, 1)); code = search (search_string, "!#$%&'()=~^|\`{[{[_+;*:]}<,>.?/ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"); if code ^= 0 then call ssu_$abort_line (sci_ptr, 0, "Invalid mask ""^a"".", substr (search_string, code, 1)); segno = va.segno; first = va.offset; range = va.range; call amu_$search_seg(amu_info_ptr, rv_ptr, rv_lth, segno, first, range, search_string, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", va.va_string); return; %page; /*****************************************************************************/ azm_requests_2_$self_identify: entry (P_sci_ptr, P_azm_info_ptr); dcl id_str char(80) varying; dcl abbrev_enabled bit(1) aligned; dcl subsys_level fixed bin; call set_up; id_str = rtrim (ssu_$get_subsystem_name (sci_ptr)); id_str = id_str || " "; id_str = id_str || rtrim(ssu_$get_subsystem_version(sci_ptr)); call ssu_$get_abbrev_info (sci_ptr, (null ()), (null()), abbrev_enabled); if abbrev_enabled then id_str = id_str || " (abbrev)"; call ssu_$get_invocation_count (sci_ptr, subsys_level, (0)); if subsys_level ^= 1 then do; id_str = id_str || " (level "; id_str = id_str || ltrim (char (subsys_level)); id_str = id_str || ")"; end; if ^trans_selected () then id_str = id_str || " No dump selected."; call ioa_ ("^a", id_str); if amu_info_ptr ^= null () then do; if amu_info.type = FDUMP_PROCESS_TYPE then do; call amu_$fdump_mgr_cur_erf (amu_info_ptr); call amu_$fdump_mpt_current_process (amu_info_ptr); end; else if amu_info.type = SAVED_PROC_TYPE then call amu_$current_deadproc (amu_info_ptr); end; return; %page; /*****************************************************************************/ azm_requests_2_$set: entry (P_sci_ptr, P_azm_info_ptr); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); if nargs <= 1 then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage: set PTR_N virtual-addr"); /* first get the pointer name */ argno = 1; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); t_pr_name = arg; /* next get the virtual address */ /* init va_args */ va_args_ptr = addr(va_args); va.range = 1; va.segno, va.offset, va.offset_modifier, va.va_position, va.ecode = 0; va.va_switches = "0"b; va.error_msg, va.va_string = ""; va.resolved_va = null(); call ssu_$arg_ptr (sci_ptr, 1, argp, argl); call amu_$get_va_args_given_start (sci_ptr, amu_info_ptr, argp, 2, nargs, va_args_ptr); if va.ecode ^= 0 | va.error_msg ^="" then do; call ssu_$abort_line (sci_ptr, va.ecode, "^a", va.error_msg); end; va.range_idx = 0; /* ranges not allowed for this request */ do argno = 2 to nargs; /* check for illegal args */ call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if ^va_arg(argno) then do; /* must be an error */ if substr(arg,1,1) = "-" then code = error_table_$badopt; else code = error_table_$bad_arg; call ssu_$abort_line(sci_ptr, code, " ^a", arg); end; end; /* processing loop */ segno = va.segno; first = va.offset; call amu_$definition_set_prn (amu_info_ptr, t_pr_name, segno, first, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Setting prN. ^a", t_pr_name); return; %page; /*****************************************************************************/ azm_requests_2_$value: entry (P_sci_ptr, P_azm_info_ptr); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); if nargs = 0 then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage: value TEMP_PTR_NAME | -all."); do argno = 1 to nargs; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if arg = "-all" | arg = "-a" then do; do i = 0 to hbound (t_ptrs, 1); call ioa_ ("^a = ^p", t_ptrs.name (i), t_ptrs.val (i)); end; return; end; t_pr_name = arg; call amu_$definition_get_prn (amu_info_ptr, t_pr_name, temp_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, ""); else call ioa_ ("^a = ^p", arg, temp_ptr); end; return; %page; /*****************************************************************************/ azm_requests_2_$verify_am: entry (P_sci_ptr, P_azm_info_ptr); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected"); do_sdws, do_ptws = "0"b; if nargs = 0 then do; do_sdws, do_ptws = "1"b; go to verify_ams; end; if nargs > 1 then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "^/Usage: vfam {-sdw | -ptw}"); argno = 1; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if arg = "-sdw" then do_sdws = "1"b; else if arg = "-ptw" then do_ptws = "1"b; else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, """^a"".", arg); verify_ams: if ^af_sw then call azm_verify_dump_ams_ (amu_info_ptr, do_sdws, do_ptws, code); else do; if azm_verify_dump_ams_$af (amu_info_ptr, do_sdws, do_ptws, code) then rs = "true"; else rs = "false"; end; if code ^= 0 then call ssu_$abort_line (sci_ptr, code, ""); return; %page; get_next_arg: proc(Arg_expected, ap1, al1); /* This guy gets the next argument from the argument string, complaining if it's not there */ dcl Arg_expected char(*); dcl (ap1 ptr, al1 fixed bin(21)); if (argno + 1) > nargs then call ssu_$abort_line(sci_ptr, error_table_$noarg, "A ^a expected after ^a.", Arg_expected, arg); argno = argno + 1; call ssu_$arg_ptr (sci_ptr, argno, ap1, al1); end get_next_arg; %page; set_up: proc; sci_ptr = P_sci_ptr; azm_info_ptr = P_azm_info_ptr; amu_info_ptr = azm_info.aip; rv_ptr = null(); rv_lth = 0; axp, configp, dsegp, start_configp = null; axstring, match_str, ret_str, temp_str = ""; brief_sw, cur_erf, del_cur_erf, del_erf, dir_sw, erfs_found, expand_ptr_sw, expand_sw, first_erf, first_value_set, forward_search, frame_entry, hdr_printed, last_erf, list_erfs, next_erf, prev_erf, print_all_trans, range_value_set, raw_syserr_data, struct_sw, why_erf = "0"b; last, ll, ln, segln = 0; slog_code = 3; call ssu_$return_arg (sci_ptr, nargs, af_sw, rv_ptr, rv_lth); if ^af_sw then call ssu_$arg_count (sci_ptr, nargs, af_sw); end set_up; %page; trans_selected: proc () returns (bit (1)); if amu_info_ptr = null () then return ("0"b); return ("1"b); end trans_selected; %page; va_arg: proc(a_pos) returns(bit(1)); dcl a_pos fixed bin; dcl i fixed bin; dcl arg_positions (3) aligned based (Ppos); dcl Ppos ptr; Ppos = addr(va.va_position); do i = 1 to hbound(arg_positions,1); if a_pos = arg_positions(i) then return("1"b); end; return("0"b); end va_arg; %page; %include amu_definitions; %page; %include amu_hardcore_info; %page; %include amu_info; %page; %include aste; %page; %include azm_info; %page; %include sdw; %page; %include ptw; %page; %include sst; %page; %include azm_va_args; %page; %include unpaged_page_tables; end azm_requests_2_;  azm_requests_3_.pl1 07/28/87 0939.2rew 07/28/87 0929.4 113589 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-01-06,Parisek), approve(87-07-09,MCR7746), audit(87-07-20,Fawcett), install(87-07-28,MR12.1-1049): Added check for the -match & -exclude control arguments. END HISTORY COMMENTS */ azm_requests_3_: proc (); return; /* not an entrypoint */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */ /* Assorted requests for analyze_multics. */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* 0) Created: 06/25/83 by B. Braun from the division of the original */ /* azm_misc_requests_. This guy contains azm requests events, sdw, syserr_log, */ /* traffic_control_queue. */ /* */ /* Modified 19 Jan 84 by BLB changes to events request so -last and -time work correctly */ /* (phx16720), to fix ioa string for invalid arg to events. */ /* Modified 08 Nov 84 by BLB to syserr_log request to change default actions from 3 to 9 */ /* Modified 21 Jan 85 by BLB to syserr_log request to change -action to take a range due */ /* the print_sys_log changes. */ /* Modified 23 Jan 85 by BLB to correct the default for events request to be "ev -tm 10" */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl ( P_sci_ptr pointer, P_azm_info_ptr pointer ) parameter; /* Automatic */ dcl af_sw bit (1) aligned; dcl all_sw bit (1); dcl axp ptr init (null); dcl argl fixed bin (21); dcl argno fixed bin; dcl argp pointer; dcl axstring char (7) init (""); dcl brief_sw bit (1) init ("0"b); dcl code fixed bin (35); dcl count fixed bin; dcl count_sw bit(1); dcl configp ptr init (null); dcl cur_erf bit (1) init ("0"b); dcl del_cur_erf bit (1) init ("0"b); dcl del_erf bit (1) init ("0"b); dcl dsegp ptr init (null); dcl erfs_found bit (1) init ("0"b); dcl expand_ptr_sw bit (1) init ("0"b); dcl expand_sw bit (1) init ("0"b); /* "1"b = expand syserr binary data */ dcl first_erf bit (1) init ("0"b); dcl first_value_set bit (1) init ("0"b); dcl forward_search bit (1) init ("0"b); dcl frame_entry bit (1) init ("0"b); dcl hdr_printed bit (1) init ("0"b); dcl hold_index fixed bin; dcl last fixed bin init (0); dcl last_erf bit (1) init ("0"b); dcl list_erfs bit (1) init ("0"b); dcl ll fixed bin init (0); dcl ln fixed bin init (0); dcl long_sw bit (1); dcl MATCH_STRING init (1) fixed bin int static options (constant); dcl EXCLUDE_STRING init (2) fixed bin int static options (constant); dcl looking_for fixed bin; dcl match_ptr ptr; dcl match_str char (256) var init (""); /* the syserr string to match on */ dcl nargs fixed bin; dcl next_erf bit (1) init ("0"b); dcl prev_erf bit (1) init ("0"b); dcl print_all_trans bit (1) init ("0"b); dcl range_value_set bit (1) init ("0"b); dcl raw_syserr_data bit (1) init ("0"b); /* "1"b = print it in octal */ dcl ret_str char (168) var init (""); dcl rv_lth fixed bin (21); dcl rv_ptr ptr; dcl sci_ptr pointer; /* assorted info pointers */ dcl segln fixed bin (35) init (0); dcl slog_code char(30) var; dcl start_configp ptr init (null); dcl struct_sw bit (1) init ("0"b); dcl temp_str char (24) var init (""); dcl time fixed bin (71); dcl time_sw bit(1); dcl why_erf bit (1) init ("0"b); /* Based */ dcl arg char (argl) based (argp); /* Constants */ /* Builtins */ dcl (abs, char, fixed, null, substr, index) builtin; /* Conditions */ dcl (conversion, quit) condition; %page; /* External Entries */ dcl amu_$fdump_mpt_change_idx entry (ptr, fixed bin); dcl amu_$tc_data_tcq entry (ptr, bit(1), bit (1)); dcl match_strings_$add entry (ptr, bit (1) aligned, char (*)); dcl azm_syserr_$data entry (ptr, ptr, fixed bin(35), char(*) var, bit (1), bit (1), char(*) var, fixed bin (35)); dcl azm_syserr_$log entry (ptr, ptr, fixed bin(35), char(*) var, bit (1), bit (1), char(*) var, fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl continue_to_signal_ entry (fixed bin(35)); dcl error_table_$noarg fixed bin (35) external static; dcl error_table_$bad_arg fixed bin (35) external static; dcl error_table_$inconsistent fixed bin (35) external static; dcl azm_display_fdump_events entry (ptr, ptr, fixed bin, fixed bin (71), bit (1), ptr, fixed bin (35)); dcl ssu_$abort_line entry options (variable); dcl ssu_$arg_count entry (pointer, fixed bin, bit (1) aligned); dcl ssu_$arg_ptr entry (pointer, fixed bin, pointer, fixed bin (21)); dcl ssu_$return_arg entry (ptr, fixed bin, bit (1) aligned, ptr, fixed bin (21)); %page; azm_requests_3_$events: entry (P_sci_ptr, P_azm_info_ptr); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); /* first set all the defaults */ time_sw, count_sw, long_sw = "0"b; match_ptr = null (); looking_for = -1; count = 10; /* last ten events */ time = 10000000; /* 10 seconds */ do argno = 1 to nargs; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if arg = "-time" | arg = "-tm" then do; time_sw = "1"b; if argno + 1 <= nargs then do; argno = argno + 1; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if char(arg, 1) = "-" then argno = argno -1; /* next control arg */ else do; on conversion goto BAD_TIME; time = fixed (arg) * 1000000; revert conversion; end; end; end; else if arg = "-last" | arg = "-lt" then do; count_sw = "1"b; if argno + 1 <= nargs then do; argno = argno + 1; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if char(arg, 1) = "-" then argno = argno -1; /* next control arg */ else do; count = cv_dec_check_ (arg, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "-number requires a decimal arg ""^a"".", arg); end; end; end; else if arg = "-long" | arg = "-lg" then long_sw = "1"b; else if arg = "-match" | arg = "-mh" then looking_for = MATCH_STRING; else if arg = "-exclude" | arg = "-ex" then looking_for = EXCLUDE_STRING; else if (char (arg, 1) = "-") then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^a.", arg); else call process_looking_for (); end; if nargs = 0 then do; /* set the default which is "ev -tm 10" */ long_sw = "0"b; time = 10000000; count = -1; end; else do; if (count_sw & time_sw) then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-count and -time"); if count_sw then time = -1; else if time_sw then count = -1; else if (^count_sw & ^time_sw & ^long_sw) & match_ptr ^= null () then do; time = 10000000; count = -1; end; end; hold_index = amu_info.process_idx; on quit begin; call amu_$fdump_mpt_change_idx (amu_info_ptr, hold_index); call continue_to_signal_(0); end; call azm_display_fdump_events (sci_ptr, amu_info_ptr, count, time, long_sw, match_ptr, code); call amu_$fdump_mpt_change_idx (amu_info_ptr, hold_index); /* ensure we are in same proc_idx that we started in */ if code ^= 0 then call ssu_$abort_line (sci_ptr, code, ""); return; BAD_TIME: call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "time."); %page; azm_requests_3_$syserr_log: entry (P_sci_ptr, P_azm_info_ptr); dcl num_msgs fixed bin(35); dcl (match_sw, exclude_sw) bit(1); call set_up; if ^trans_selected () then do; call ssu_$abort_line (sci_ptr, 0, "No dump selected."); return; end; slog_code = "-100:100"; /* set the default */ num_msgs = -1; exclude_sw, match_sw = "0"b; expand_sw = "0"b; match_str = ""; if nargs = 0 then go to no_wlog_args; do argno = 1 to nargs; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if arg = "-expand" | arg = "-exp" then expand_sw = "1"b; else if arg = "-action" then do; call get_next_arg("Action code", argp, argl); if index(arg, ":") = 0 then /* must construct the range */ slog_code = "-100:" || arg; else slog_code = arg; end; else if arg = "-match" | arg = "-exclude" | arg = "-ex" then do; match_str = ""; if arg = "-match" then do; match_sw = "1"b; exclude_sw = "0"b; end; else do; exclude_sw = "1"b; match_sw = "0"b; end; call get_next_arg("String", argp, argl); if substr(arg, 1, 1) = "-" then call ssu_$abort_line(sci_ptr, error_table_$noarg, " Missing match strings."); match_str = arg; end; else if arg = "-last" | arg = "-lt" then do; call get_next_arg("Decimal Number", argp, argl); num_msgs = cv_dec_check_ (arg, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "-last requires a decimal arg ""^a"".", arg); end; else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, """^a"".", arg); end; no_wlog_args: call azm_syserr_$data (sci_ptr, amu_info_ptr, num_msgs, match_str, match_sw, expand_sw, slog_code, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, ""); call azm_syserr_$log (sci_ptr, amu_info_ptr, num_msgs, match_str, match_sw, expand_sw, slog_code, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, ""); return; /* end azm_requests_3_$syserr_log */ %page; azm_requests_3_$tcq: entry (P_sci_ptr, P_azm_info_ptr); dcl rdy_sw bit(1); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); all_sw, rdy_sw = "0"b; do argno = 1 to nargs; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if arg = "-all" | arg = "-a" then all_sw = "1"b; else if arg = "-rdy" | arg = "-ready" then rdy_sw = "1"b; else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, """^a"".", arg); end; if all_sw & rdy_sw then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-all -ready"); call amu_$tc_data_tcq (amu_info_ptr, all_sw, rdy_sw); return; %page; get_next_arg: proc(Arg_expected, ap1, al1); /* This guy gets the next argument from the argument string, complaining if it's not there */ dcl Arg_expected char(*); dcl (ap1 ptr, al1 fixed bin(21)); if (argno + 1) > nargs then do; call ssu_$abort_line(sci_ptr, error_table_$noarg, "A ^a expected after ^a.", Arg_expected, arg); return; end; argno = argno + 1; call ssu_$arg_ptr (sci_ptr, argno, ap1, al1); end get_next_arg; %page; set_up: proc; sci_ptr = P_sci_ptr; azm_info_ptr = P_azm_info_ptr; amu_info_ptr = azm_info.aip; call ssu_$return_arg (sci_ptr, nargs, af_sw, rv_ptr, rv_lth); if ^af_sw then call ssu_$arg_count (sci_ptr, nargs, af_sw); end set_up; %page; trans_selected: proc () returns (bit (1)); if amu_info_ptr = null () then return ("0"b); return ("1"b); end trans_selected; %page; process_looking_for: proc (); dcl really_looking_for fixed bin; really_looking_for = abs (looking_for); if really_looking_for = MATCH_STRING | really_looking_for = EXCLUDE_STRING then if substr (arg, 1, 1) = "/" & substr (arg, argl, 1) ^= "/" then INVALID_REGULAR_EXPRESSION: call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "Invalid regular expression ""^a""", arg); else if substr (arg, argl, 1) = "/" & substr (arg, 1, 1) ^= "/" then goto INVALID_REGULAR_EXPRESSION; else if arg = "/" then goto INVALID_REGULAR_EXPRESSION; if (really_looking_for = MATCH_STRING) then call match_strings_$add (match_ptr, "1"b, arg); else if (really_looking_for = EXCLUDE_STRING) then call match_strings_$add (match_ptr, "0"b, arg); return; end process_looking_for; %page; %include amu_info; %page; %include azm_info; end azm_requests_3_;  azm_ret_x7_stack_.alm 11/19/84 1143.5rew 11/15/84 1440.1 10872 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1983 * " * * " *********************************************************** name azm_ret_x7_stack_ entry pxss entry page include pxss_page_stack " This will return the relative address for the stack frame base " of the x7 stack save area for page_control or pxss. " " " dcl azm_ret_x7_stack_$pxss entry (fixed bin,fixed bin,fixed bin); " call azm_ret_x7_stack_$pxss (frame_offset,valid_entries,savex_stack_size); " " where frame_offset is the offset from stack_frame ptr for the stack. " valid_entries is the number a entries. " savex_stack_size is the size of the stack pxss: push eax1 pr6|0 stx1 temp1 eax2 pxss_save_stack sbx2 temp1 stz ap|2,* sxl2 ap|2,* eax3 pxss_stackp sbx3 temp1 stz ap|4,* sxl3 ap|4,* ldq pxss_stack_size,dl stq ap|6,* return page: push eax1 pr6|0 stx1 temp1 eax2 save_stack sbx2 temp1 stz ap|2,* sxl2 ap|2,* eax3 stackp sbx3 temp1 stz ap|4,* sxl3 ap|4,* lda stack_size,dl sta ap|6,* return end  azm_stack_requests_.pl1 07/28/87 0939.2rew 07/28/87 0924.3 94464 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-12-16,Parisek), approve(87-07-09,MCR7746), audit(87-07-16,Fawcett), install(87-07-28,MR12.1-1049): ssu_$print_message is called instead of ssu_$abort_line if a stack segment cannot be located, therefore execution may resume during active requests (phx19331). END HISTORY COMMENTS */ azm_stack_requests_: proc (); return; /* not an entrypoint */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */ /* Assorted requests for analyze_multics. */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* 0) Created: 06/25/83 by B. Braun from the division of the original azm_misc_requests_ */ /* into smaller modules. This includes the azm requests stack, frame, why. */ /* 1) Modified Sept 1984 by R. A. Fawcett to add azm_stack_requests_$locks (This should be some where else??). */ /* 2) Modified Sept 1984 by R. A. Fawcett to add azm_stack_requests_$search_mcs. */ /* 3) Modified Jan 1985 by B. Braun to change the why request message when it cannot find */ /* the cause of the failure. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl ( P_sci_ptr pointer, P_azm_info_ptr pointer ) parameter; /* Automatic */ dcl af_sw bit (1) aligned; dcl arg_sw bit (1); dcl argl fixed bin (21); dcl argno fixed bin; dcl argp pointer; dcl brief_sw bit (1) init ("0"b); dcl code fixed bin (35); dcl count fixed bin; dcl first fixed bin(18); dcl for_sw bit (1); dcl force_sw bit (1); dcl fwd_sw bit (1); dcl long_sw bit (1); dcl lock_index fixed bin (17); dcl 1 lock_info (0:6), 2 lseg char (32) init ("tc_data", "sst_seg", "sst_seg", "scs", "tty_buf", "tty_buf","disk_seg"), 2 lsymb char (32) init ("apt_lock", "ptl", "astl", "connect_lock", "slock", "timer_lock","lock"), 2 lock_word bit (36) init ("0"b, "0"b, "0"b, "0"b, "0"b, "0"b,"0"b); dcl lock_name char (32); dcl nargs fixed bin; dcl ret_str char (168) var init (""); dcl rv_lth fixed bin (21); dcl rv_ptr ptr; dcl sci_ptr pointer; /* assorted info pointers */ dcl segno fixed bin; dcl set_sw bit (1); dcl struct_sw bit (1) init ("0"b); dcl temp_ptr ptr; dcl val_arg fixed bin; %page; /* Based */ dcl arg char (argl) based (argp); /* Constants */ /* Builtins */ dcl (addr, baseptr, hbound, pointer, null, substr) builtin; /* Conditions */ %page; /* External Entries */ dcl amu_$get_va_args entry (ptr, ptr, ptr, fixed bin, ptr); dcl azm_stack_trace_ entry (char(*), ptr, ptr, ptr, bit (1), bit (1), bit (1), bit (1), fixed bin, fixed bin (35)); dcl azm_why_$find_bad_guy entry (ptr, ptr, fixed bin (35)); dcl azm_why_$mcs entry (ptr, ptr, fixed bin(35)); dcl azm_why_$print_locks entry (ptr, ptr, char(*), bit(1), fixed bin(35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl ioa_ entry options (variable); dcl ssu_$abort_line entry options (variable); dcl ssu_$arg_count entry (pointer, fixed bin, bit (1) aligned); dcl ssu_$arg_ptr entry (pointer, fixed bin, pointer, fixed bin (21)); dcl ssu_$print_message entry() options(variable); dcl ssu_$return_arg entry (ptr, fixed bin, bit (1) aligned, ptr, fixed bin (21)); /* error codes */ dcl amu_et_$no_valid_stacks fixed bin (35) external static; dcl error_table_$action_not_performed fixed bin(35) ext static; dcl error_table_$bad_arg fixed bin (35) external static; dcl error_table_$badopt fixed bin (35) external static; dcl error_table_$noarg fixed bin (35) external static; dcl error_table_$too_many_args fixed bin(35) ext static; %page; azm_stack_requests_$frame: entry (P_sci_ptr, P_azm_info_ptr); sci_ptr = P_sci_ptr; call ssu_$abort_line (sci_ptr, 0, "This request has not been implemented yet."); %page; azm_stack_requests_$stack: entry (P_sci_ptr, P_azm_info_ptr); call set_up; if ^trans_selected () then call ssu_$abort_line (sci_ptr, 0, "No dump selected."); if nargs = 0 then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage: stack {-ctl_args}."); /* init va_args */ va_args_ptr = addr(va_args); va.range = 0; va.segno, va.offset, va.offset_modifier, va.va_position, va.ecode = 0; va.va_switches = "0"b; va.error_msg, va.va_string = ""; va.resolved_va = null(); call ssu_$arg_ptr (sci_ptr, 1, argp, argl); call amu_$get_va_args(sci_ptr, amu_info_ptr, argp, nargs, va_args_ptr); if va.ecode ^= 0 | va.error_msg ^="" then do; call ssu_$abort_line (sci_ptr, va.ecode, "^a", va.error_msg); end; fwd_sw, for_sw, arg_sw, long_sw, force_sw = "0"b; count, val_arg = 0; va.range_idx = 0; /* range is not allowed for stack request */ do argno = 1 to nargs; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if arg = "-lg" | arg = "-long" then long_sw = "1"b; else if arg = "-ag" | arg = "-arguments" then arg_sw = "1"b; else if arg = "-force" | arg = "-fc" then force_sw = "1"b; else if arg = "-for" then do; call get_next_arg("decimal number", argp, argl); count = cv_dec_check_ (arg, code); if code ^= 0 | count < 0 then call ssu_$abort_line (sci_ptr, 0, "-for requires a positive decimal number ""^a""."); for_sw = "1"b; end; else if arg = "-fwd" | arg = "-forward" then fwd_sw = "1"b; else do; if ^va_arg(argno) then do; if substr(arg,1,1) = "-" then code = error_table_$badopt; else code = error_table_$bad_arg; call ssu_$abort_line(sci_ptr, code, " ^a", arg); end; end; end; /* arg processing */ segno = va.segno; first = va.offset; temp_ptr = pointer (baseptr (segno), first); call azm_stack_trace_ ("stack", sci_ptr, amu_info_ptr, temp_ptr, fwd_sw, arg_sw, long_sw, force_sw, count, code); if code ^= 0 then do; if code = amu_et_$no_valid_stacks then do; call ioa_ ("Frames may be invalid."); call ioa_ ("Stack_begin and stack_end are equal ^p.", temp_ptr); call ioa_ ("Use the -force and -fwd options and proceed at your own risk!"); end; else call ssu_$print_message (sci_ptr, code, "trace of stack ^p.", temp_ptr); end; return; %page; azm_stack_requests_$why: entry (P_sci_ptr, P_azm_info_ptr); call set_up; if ^trans_selected () then do; call ssu_$abort_line (sci_ptr, 0, "No dump selected."); return; end; if nargs ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "This request takes no arguments."); call azm_why_$find_bad_guy (sci_ptr, amu_info_ptr, code); if code = error_table_$action_not_performed then do; call ssu_$print_message (sci_ptr,0,"Unable to determine the cause of the failure."); return; end; if code ^= 0 then do; call ssu_$abort_line (sci_ptr, code, "why."); end; return; /* End why */ %page; azm_stack_requests_$locks: entry (P_sci_ptr, P_azm_info_ptr); call set_up; if ^trans_selected () then do; call ssu_$abort_line (sci_ptr, 0, "No dump selected."); return; end; if nargs > 3 then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "This request takes 2 arguments max."); lock_name = ""; set_sw = "0"b; do argno = 1 to nargs; call ssu_$arg_ptr (sci_ptr, argno, argp, argl); if arg = "-set" then set_sw = "1"b; else do; do lock_index = 0 to hbound(lock_info,1); if arg = lock_info (lock_index).lsymb then do; lock_name = arg; goto call_lock_list; end; end; call ioa_ ("valid locks are:"); do lock_index = 0 to hbound(lock_info,1); call ioa_ ("^-^a",lock_info(lock_index).lsymb); end; return; end; end; call_lock_list: call azm_why_$print_locks (sci_ptr, amu_info_ptr, lock_name,set_sw,code); if code ^= 0 then do; call ssu_$abort_line (sci_ptr, code, "locks."); end; return; /* End locks */ %page; azm_stack_requests_$search_mcs: entry (P_sci_ptr, P_azm_info_ptr); call set_up; if ^trans_selected () then do; call ssu_$abort_line (sci_ptr, 0, "No dump selected."); return; end; if nargs ^= 0 then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "This request takes no arguments."); call azm_why_$mcs (sci_ptr,amu_info_ptr,code); if code ^= 0 then call ssu_$print_message (sci_ptr,code); return; /* end search_mcs */ %page; get_next_arg: proc(Arg_expected, ap1, al1); /* This guy gets the next argument from the argument string, complaining if it's not there */ dcl Arg_expected char(*); dcl (ap1 ptr, al1 fixed bin(21)); if (argno + 1) > nargs then do; call ssu_$abort_line(sci_ptr, error_table_$noarg, "A ^a expected after ^a.", Arg_expected, arg); return; end; argno = argno + 1; call ssu_$arg_ptr (sci_ptr, argno, ap1, al1); end get_next_arg; %page; set_up: proc; sci_ptr = P_sci_ptr; azm_info_ptr = P_azm_info_ptr; amu_info_ptr = azm_info.aip; call ssu_$return_arg (sci_ptr, nargs, af_sw, rv_ptr, rv_lth); if ^af_sw then call ssu_$arg_count (sci_ptr, nargs, af_sw); end set_up; %page; trans_selected: proc () returns (bit (1)); if amu_info_ptr = null () then return ("0"b); return ("1"b); end trans_selected; %page; va_arg: proc(a_pos) returns(bit(1)); dcl a_pos fixed bin; dcl i fixed bin; dcl arg_positions (3) aligned based (Ppos); /*dcl 1 arg_positions aligned based (Ppos), 2 indx (3) fixed bin; */ dcl Ppos ptr; Ppos = addr(va.va_position); do i = 1 to hbound(arg_positions,1); if a_pos = arg_positions(i) then return("1"b); end; return("0"b); end va_arg; %page; %include amu_info; %page; %include amu_translation; %page; %include azm_info; %page; %include azm_va_args; end azm_stack_requests_;  azm_stack_trace_.pl1 10/24/88 1629.2r w 10/24/88 1401.1 379359 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-12-10,DGHowe), approve(86-12-10,MCR7595), audit(87-01-07,JRGray), install(87-01-09,MR12.0-1267): Changed to use include file arg_list.incl.pl1 and to check the mbz in command_name_arglist rather than the pad2 field in arg_list for zero. 2) change(86-12-15,Parisek), approve(87-07-09,MCR7746), audit(87-07-23,Fawcett), install(87-07-28,MR12.1-1049): Eliminate "garbage" in argument displays because of bad pointer offset values, and look at proper arg list structure when call_type is Envptr_supplied_call_type. 3) change(87-06-29,Parisek), approve(87-07-09,MCR7746), audit(87-07-23,Fawcett), install(87-07-28,MR12.1-1049): Increased the string size of bound_comp_name from 64 chars to 128 chars since some pathnames exceed 64 chars. END HISTORY COMMENTS */ azm_stack_trace_: proc (P_caller, P_sci_ptr, P_amu_info_ptr, P_stack_ptr, P_fwd_sw, P_arg_sw, P_long_sw, P_force_sw, P_for_number, P_code); /* Modified 12/1/83 by B. Braun to not call interpret_ptr_ to obtain info for the ARGs of a stack frame. This is because interpret_ptr_ references the current process and not the FDUMP, So we call amu_$get_name instead. Modified Sept 1984 by R. A. Fawcett to remove displaying args when looking for an entry also remove warning messages from frame_args_ and look for argumnet data via "hunt" so that the object code can be found . Modified Jan 21 1985 by B. Braun to add a P_caller to all entries. */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */ /* Parameters */ dcl (P_amu_info_ptr, P_sci_ptr, P_stack_ptr, P_entry_ptr) ptr; dcl (P_fwd_sw, P_arg_sw, P_long_sw, P_force_sw) bit (1); dcl P_for_number fixed bin; dcl P_code fixed bin (35); dcl P_ring_zero bit (1); /* Automatic */ dcl P_caller char(*); dcl temp_ptr ptr init (null); dcl entry_name char (36) init (""); dcl (pxss_ptr, page_ptr) ptr init (null); dcl wire_ptr ptr init (null ()); dcl frame_number fixed bin init (0); dcl search_entry_ptr ptr init (null); dcl temp_proc_hold fixed bin init (0); dcl (stop, no_arg_ptr, not_first) bit (1) init ("0"b); dcl stack_frames_fwd fixed bin init (0); dcl stack_frames_rev fixed bin init (0); dcl number_mcs fixed bin init (0); dcl next_frame_mc bit (1); dcl check_err_sw bit (1) init ("0"b); dcl for_number fixed bin init (0); dcl number_of_valid_stacks fixed bin init (0); dcl code fixed bin (35) init (0); dcl (offset, first) fixed bin (18) init (0); dcl stack_offset fixed bin (18) init (0); dcl segno fixed bin init (0); dcl bound_comp_name char (128) init (""); dcl based_regs (8) fixed bin (35) based; dcl data_buf_ptr ptr init (null); dcl (fwd_sw, arg_sw, long_sw, force_sw, error_rev, error_fwd, pg_err) bit (1) init ("0"b); dcl (save_prev_sp, save_next_sp) ptr init (null); dcl (last_found_fwd_sp, last_found_rev_sp) ptr init (null); dcl stack_ptr ptr init (null); dcl 1 temp_trans like translation; dcl frames_array_fwd (stack_frames_fwd) ptr based (frames_fwd_ptr); dcl frames_array_rev (stack_frames_rev) ptr based (frames_rev_ptr); dcl frames_fwd_ptr ptr init (null); dcl frames_rev_ptr ptr init (null); dcl temp_word bit (36) aligned init ("0"b); dcl temp_desc fixed bin (35) init (0); dcl temp_entry_ptr ptr init (null); dcl (temp_arg_ptr, temp_desc_ptr) ptr init (null); dcl 1 page_err_regs, 2 pg_ptr (0:7) ptr, 2 ou_regs (8) fixed bin (35); dcl sys_info$max_seg_size fixed bin (35) ext static; dcl max_stack_size fixed bin (18); dcl fwd_bound_sw bit (1) init ("0"b); dcl max_words fixed bin (18) init (0); dcl argp ptr init (null); dcl ap ptr init (null); /* ptr to arglist. */ dcl strp ptr init (null); dcl tp ptr init (null); dcl xdesc (64) ptr; dcl tdesc (64) ptr; dcl t_args_p (0:128) ptr; dcl arg_list_length fixed bin (18) init (0); dcl (i, j, jd, k) fixed bin init (0); dcl (min_arg, max_arg, type, xtype) fixed bin init (0); dcl (no_args, no_desc, strl, ndims, scale) fixed bin init (0); dcl (xstrl, xndims, xscale, xnargs, tnargs) fixed bin init (0); dcl c75 char (75) aligned init (""); dcl (ttype, xttype) char (40) init (""); dcl ascii_representation char (132) varying init (""); dcl (packed, xpacked) bit (1) aligned init ("0"b); dcl begin_block_entries (2) bit (36) aligned internal static options (constant) init ("000614272100"b3 /* tsp2 pr0|614 */, "001376272100"b3 /* tsp2 pr0|1376 */); dcl 1 its_ptr aligned like its; dcl ptr_array (0:10) ptr based (argp); dcl packptr ptr based unaligned; dcl fword (4) fixed bin (35) based (argp); dcl bcs char (100) based (argp); dcl char_string char (strl) based (argp); dcl based_bit bit (36) aligned based; dcl bit_string bit (strl) based (argp); dcl 1 label_variable based (argp) aligned, 2 ptr ptr, 2 stack ptr; dcl 1 temp_arg, 2 var_pad fixed bin, /* placed here so args can start on mod 2 bound */ 2 var_length fixed bin, /* if desc type is varing */ 2 a_buf (50) fixed bin (71); /* save 100 words for translation of arg */ dcl log_seg_ptr ptr; dcl log_mess_len fixed bin (21); dcl log_mess char (log_mess_len) based (log_seg_ptr); dcl LEGAL char (96) int static init /* Printables except PAD, but with BS */ ( " !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~"); dcl ( amu_et_$not_implemented, amu_et_$no_translation, amu_et_$looping_problem, error_table_$action_not_performed, error_table_$seg_not_found, amu_et_$invalid_segno, amu_et_$entry_not_found, amu_et_$no_valid_stacks, amu_et_$not_stack_seg, amu_et_$end_ptr_oob ) fixed bin (35) ext static; dcl ( ioa_, ioa_$nnl, ioa_$rsnnl ) entry () options (variable); dcl condition_ entry (char (*), entry); dcl get_entry_arg_descs_ entry (ptr, fixed bin, (*) ptr, fixed bin (35)); dcl decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin); dcl sci_ptr ptr; dcl arithmetic_to_ascii_ entry (ptr, fixed bin, bit (1) aligned, fixed bin, fixed bin, char (132) varying); dcl amu_$definition_set_prn entry (ptr, char (*), fixed bin, fixed bin (18), fixed bin (35)); dcl amu_$definition_ptr entry (ptr, char (*), char (*), fixed bin (35)) returns (ptr); dcl azm_syserr_$returns_string entry (ptr, ptr, fixed bin, fixed bin (35), ptr, fixed bin (21), fixed bin (35)); dcl azm_ret_x7_stack_$pxss entry (fixed bin, fixed bin, fixed bin); dcl azm_ret_x7_stack_$page entry (fixed bin, fixed bin, fixed bin); dcl amu_$return_val_per_process entry (ptr, fixed bin) returns (bit (1)); dcl amu_$fdump_mpt_change_idx entry (ptr, fixed bin); dcl amu_$error_for_caller entry () options (variable); dcl amu_$print_dump_oct entry (ptr, fixed bin (18), fixed bin (18)); dcl amu_$get_name entry (ptr, ptr) returns (char (*)); dcl amu_$get_name_no_comp entry (ptr, ptr) returns (char (*)); dcl amu_$translate_get entry (ptr, fixed bin, ptr, fixed bin (35)); dcl amu_$translate_force_add entry (ptr, ptr, fixed bin, fixed bin (35)); dcl amu_$fdump_translate_to_temp_seg entry (ptr, ptr, ptr, fixed bin (35)); dcl ssu_$get_temp_segment entry (ptr, char(*), ptr); dcl ssu_$print_message entry() options(variable); dcl ssu_$release_temp_segment entry (ptr, ptr); dcl amu_$do_translation_by_ptr entry (ptr, ptr, fixed bin (18), ptr, fixed bin (35)); dcl amu_$do_translation_hunt_ptr entry (ptr, ptr, ptr, fixed bin (35)); dcl amu_$do_translation_hunt entry (ptr, fixed bin, ptr, fixed bin (18), fixed bin (18), fixed bin (35)); dcl amu_$definition_set_from entry (ptr, char (*), ptr, fixed bin (35)); dcl azm_display_mc_ entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl azm_display_mc_$regs_only entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl (addr, addrel, baseno, baseptr, index, hbound, lbound, min, null, pointer, substr, fixed, max, rel, rtrim, verify, unspec) builtin; dcl (cleanup, fault_tag_1) condition; %page; entry_name = "azm_stack_trace"; sci_ptr = P_sci_ptr; for_number = P_for_number; frames_fwd_ptr = null (); frames_rev_ptr = null (); amu_info_ptr = P_amu_info_ptr; stack_ptr = P_stack_ptr; fwd_sw = P_fwd_sw; force_sw = P_force_sw; arg_sw = P_arg_sw; long_sw = P_long_sw; on condition(cleanup) begin; if frames_fwd_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, frames_fwd_ptr); if frames_rev_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, frames_rev_ptr); end; call get_stack; if code ^= 0 then goto ERROR; if stack_offset = 0 then do; sp = pointer (sb, fixed (rel (stack_header.stack_begin_ptr), 18)); if fixed (rel (sp), 18) >= fixed (rel (stack_header.stack_end_ptr), 18) then do; if ^force_sw then do; P_stack_ptr = stack_header.stack_end_ptr; code = amu_et_$no_valid_stacks; goto ERROR; end; else fwd_sw = "1"b; end; end; else do; sp = pointer (sb, stack_offset); /* use the offset the user gave us */ force_sw = "1"b; end; error_rev, error_fwd = "0"b; stack_frames_fwd, stack_frames_rev = 0; call CHECK_THREAD; if code ^= 0 then goto ERROR; if fwd_sw then sp = frames_array_fwd (1); else sp = frames_array_rev (1); stop = "0"b; if ^fwd_sw & error_rev & ^force_sw then do; call ioa_ ("Trace will be Forward."); fwd_sw = "1"b; end; PRINT_STACK: on fault_tag_1 begin; call ssu_$print_message (sci_ptr,0,"fault_tag_1 cannot continue"); P_code,code = 0; goto NORMAL_RETURN; end; call ioa_ ("^/^[Forward^;Reverse^] trace of ^a (Seg ^o)", fwd_sw, amu_$get_name_no_comp (amu_info_ptr, P_stack_ptr), fixed (baseno (P_stack_ptr), 17)); call ioa_ ("Number of stack frames ^[^d^;^s^]^[^d^;^s^].^[^/Previous stack frame ^p.^]", fwd_sw, stack_frames_fwd, ^fwd_sw, stack_frames_rev, fwd_sw, stack_frame.prev_sp); call ioa_ ("Stack begin = ^p Stack end = ^p", stack_header.stack_begin_ptr, stack_header.stack_end_ptr); call ioa_ ("FRAME^13tRETURN_PTR"); frame_number, number_mcs = 0; pxss_ptr = amu_$definition_ptr (amu_info_ptr, "pxss", "block", code); if code ^= 0 then do; P_code = code; return; end; page_ptr = amu_$definition_ptr (amu_info_ptr, "page_fault", "done", code); if code ^= 0 then do; P_code = code; return; end; call check_next; pg_err = "0"b; do while (^stop); bound_comp_name = amu_$get_name (amu_info_ptr, stack_frame.return_ptr); call ioa_ ("^12p^12p ^a", real_ptr (sp), pointer(stack_frame.return_ptr,rel(stack_frame.return_ptr)), bound_comp_name); call savex_stack_; call mc_frame ("0"b); if long_sw | arg_sw then do; call display_args; if index (bound_comp_name, "$page_error") ^= 0 then do; if fwd_sw then do; if ^pg_err then do; call display_page_err_regs; call ioa_ (" "); pg_err = "1"b; end; end; else do; if pg_err then do; call display_page_err_regs; call ioa_ (" "); pg_err = "0"b; end; else pg_err = "1"b; end; end; end; no_arg_ptr = "0"b; if long_sw then call display_frame; call check_next; end; if ^fwd_sw then do; call ioa_ ("Previous stack frame ^p", stack_frame.prev_sp); end; if error_fwd & error_rev & ^force_sw then do; fwd_sw = ^fwd_sw; error_fwd, error_rev = "0"b; goto PRINT_STACK; end; P_code = 0; goto NORMAL_RETURN; %page; ERROR: P_code = code; NORMAL_RETURN: if frames_fwd_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, frames_fwd_ptr); if frames_rev_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, frames_rev_ptr); return; %page; azm_stack_trace_$check_for_entry: entry (P_caller, P_sci_ptr, P_amu_info_ptr, P_stack_ptr, P_entry_ptr, P_code); entry_name = "azm_stack_trace_$check_for_entry"; search_entry_ptr = P_entry_ptr; sci_ptr = P_sci_ptr; check_err_sw = "0"b; call common_check_entry(); P_code = code; goto NORMAL_RETURN; %page; azm_stack_trace_$check_for_mc: entry (P_caller, P_sci_ptr, P_amu_info_ptr, P_stack_ptr, P_ring_zero, P_code); code, P_code = 0; entry_name = "azm_stack_trace_$check_for_mc"; sci_ptr = P_sci_ptr; force_sw = "0"b; call set_up_search; if code ^= 0 then goto ERROR; fwd_sw = "1"b; number_mcs = 0; call check_next; do while (^stop); if P_ring_zero | next_frame_mc then do; if number_mcs = 0 then call mc_frame ("1"b); else call mc_frame ("0"b); end; if stack_frame_flags.signaller then next_frame_mc = "1"b; else next_frame_mc = "0"b; if number_mcs = 4 then do; code = amu_et_$looping_problem; goto ERROR; end; if code ^= 0 then goto ERROR; call check_next; end; if number_mcs = 0 then P_code = error_table_$action_not_performed; goto NORMAL_RETURN; %page; azm_stack_trace_$check_for_syserr: entry (P_caller, P_sci_ptr, P_amu_info_ptr, P_stack_ptr, P_code); entry_name = "azm_stack_trace_$check_for_syserr"; amu_info_ptr = P_amu_info_ptr; sci_ptr = P_sci_ptr; search_entry_ptr = amu_$definition_ptr (amu_info_ptr, "syserr_real", "syserr_real", code); if code ^= 0 then goto ERROR; check_err_sw = "1"b; wire_ptr = amu_$definition_ptr (amu_info_ptr, "wire_stack", "wire_stack", code); call common_check_entry(); if code = amu_et_$entry_not_found then do; search_entry_ptr = amu_$definition_ptr (amu_info_ptr, "syserr_real", "binary", code); if code ^= 0 then goto ERROR; call common_check_entry(); if code = amu_et_$entry_not_found then do; search_entry_ptr = amu_$definition_ptr (amu_info_ptr, "syserr_real", "error_code", code); if code ^= 0 then goto ERROR; call common_check_entry(); end; end; P_code = code; goto NORMAL_RETURN; %page; check_next: proc; frame_number = frame_number + 1; if for_number >= 1 then if frame_number > for_number then do; stop = "1"b; return; end; if fwd_sw then do; if frame_number > stack_frames_fwd then do; stop = "1"b; end; else sp = frames_array_fwd (frame_number); end; else do; if frame_number > stack_frames_rev then do; stop = "1"b; end; else sp = frames_array_rev (frame_number); end; end check_next; %page; CHECK_THREAD: proc; fwd_bound_sw = "0"b; max_stack_size = sys_info$max_seg_size; if force_sw then if ^fwd_sw then goto Check_stack_thread_rev; call ssu_$get_temp_segment (sci_ptr, "stack_frames_fwd", frames_fwd_ptr); Check_stack_thread_fwd: on fault_tag_1 begin; goto stack_error_fwd; end; stop = "0"b; not_first = "0"b; save_prev_sp = stack_frame.prev_sp; do while (^stop); if (fixed (rel (stack_frame.next_sp), 18) < max_stack_size) then if thread_ptr_val (stack_frame.next_sp, not_first) then if (fixed (rel (sp), 18) < fixed (rel (stack_frame.next_sp), 18)) then if fixed (rel (stack_frame.next_sp), 18) <= fixed (rel (stack_header.stack_end_ptr), 18) then if fixed (rel (stack_frame.next_sp), 18) ^= fixed (rel (stack_header.stack_end_ptr)) then do; fwd_next_frame: do i = 1 to stack_frames_fwd; if frames_array_fwd (i) = sp then do; call ioa_ ("Stack frame wraps around"); stop = "1"b; end; end; stack_frames_fwd = stack_frames_fwd + 1; frames_array_fwd (stack_frames_fwd) = sp; save_prev_sp = sp; not_first = "1"b; sp = pointer (sb, fixed (rel (stack_frame.next_sp), 18)); end; else do; stop = "1"b; stack_frames_fwd = stack_frames_fwd + 1; frames_array_fwd (stack_frames_fwd) = sp; end; else do; if force_sw then goto fwd_next_frame; else do; call ioa_ ("^-(fwd) next_sp > stack_end_ptr for frame ^p", real_ptr (sp)); goto stack_error_fwd; end; end; else do; call ioa_ ("^-(fwd) next_sp >= sp: sp = ^p", real_ptr (sp)); goto stack_error_fwd; end; else do; call ioa_ ("^-(fwd) next_sp not valid ^p sp ^p", stack_frame.next_sp, real_ptr (sp)); goto stack_error_fwd; end; else do; call ioa_ ("^-(fwd) next_sp out_of_bounds ^p sp ^p", stack_frame.next_sp, real_ptr (sp)); fwd_bound_sw = "1"b; goto stack_error_fwd; end; end; goto good_thread_fwd; stack_error_fwd: stack_frames_fwd = stack_frames_fwd + 1; frames_array_fwd (stack_frames_fwd) = sp; error_fwd = "1"b; good_thread_fwd: revert fault_tag_1; last_found_fwd_sp = sp; if force_sw then return; /* Now check rev */ Check_stack_thread_rev: on fault_tag_1 begin; goto stack_error_rev; end; call ssu_$get_temp_segment (sci_ptr, "stack_frames_rev", frames_rev_ptr); stop = "0"b; not_first = "1"b; if stack_offset = 0 then do; if fwd_bound_sw then sp = last_found_fwd_sp; if (fixed (rel (stack_header.stack_end_ptr), 18) < max_stack_size) then sp = pointer (sb, fixed (rel (stack_header.stack_end_ptr), 18)); else do; if force_sw & ^fwd_sw then do; code = amu_et_$end_ptr_oob; return; end; end; if ^thread_ptr_val (stack_frame.prev_sp, not_first) then do; sp = last_found_fwd_sp; end; else do; sp = pointer (sb, fixed (rel (stack_frame.prev_sp), 18)); end; end; else do; sp = pointer (sp, stack_offset); end; if ^thread_ptr_val (stack_frame.next_sp, not_first) then do; sp = last_found_fwd_sp; end; do while (^stop); if thread_ptr_val (stack_frame.prev_sp, not_first) then if (fixed (rel (sp), 18) > fixed (rel (stack_frame.prev_sp), 18)) | rel (sp) = rel (stack_header.stack_begin_ptr) then if fixed (rel (stack_frame.prev_sp), 18) >= fixed (rel (stack_header.stack_begin_ptr), 18) then if fixed (rel (sp), 18) ^= fixed (rel (stack_header.stack_begin_ptr)) then do; rev_next_frame: do i = 1 to stack_frames_rev; if frames_array_rev (i) = sp then do; call ioa_ ("Stack frame wraps around"); stop = "1"b; end; end; save_next_sp = sp; stack_frames_rev = stack_frames_rev + 1; frames_array_rev (stack_frames_rev) = sp; sp = pointer (sb, fixed (rel (stack_frame.prev_sp), 18)); if fixed (rel (sp), 18) = fixed (rel (stack_header.stack_begin_ptr), 18) then not_first = "0"b; end; else do; stack_frames_rev = stack_frames_rev + 1; frames_array_rev (stack_frames_rev) = sp; stop = "1"b; end; else do; if fixed (rel (sp), 18) = fixed (rel (stack_header.stack_begin_ptr), 18) then do; stop = "1"b; stack_frames_rev = stack_frames_rev + 1; frames_array_rev (stack_frames_rev) = sp; end; else do; call ioa_ ("^-(rev) prev_sp (^p) < stack_begin_ptr for frame ^p", stack_frame.prev_sp, real_ptr (sp)); goto stack_error_rev; end; end; else do; call ioa_ ("^-(rev) prev_sp ^p > sp for frame ^p", stack_frame.prev_sp, real_ptr (sp)); goto stack_error_rev; end; else do; call ioa_ ("^-(rev) prev_sp not valid ^p for frame ^p", stack_frame.prev_sp, real_ptr (sp)); goto stack_error_rev; end; end; goto good_thread_rev; stack_error_rev: stack_frames_rev = stack_frames_rev + 1; frames_array_rev (stack_frames_rev) = sp; error_rev = "1"b; good_thread_rev: revert fault_tag_1; last_found_rev_sp = sp; return; end CHECK_THREAD; %page; common_check_entry: proc(); dcl this_frame bit (1); fwd_sw = "0"b; force_sw = "0"b; call set_up_search; if code ^= 0 then return; stop = "0"b; pxss_ptr = amu_$definition_ptr (amu_info_ptr, "pxss", "block", code); if code ^= 0 then return; page_ptr = amu_$definition_ptr (amu_info_ptr, "page_fault", "done", code); if code ^= 0 then return; pg_err = "0"b; call check_next; do while (^stop); this_frame = "0"b; bound_comp_name = " "; if stack_frame.entry_ptr = search_entry_ptr then this_frame = "1"b; if check_err_sw then do; bound_comp_name = amu_$get_name (amu_info_ptr, stack_frame.entry_ptr); if index(bound_comp_name,"syserr_real") ^= 0 then this_frame = "1"b; end; if this_frame then do; if check_err_sw then do; call ssu_$get_temp_segment (sci_ptr, rtrim(entry_name),log_seg_ptr); call azm_syserr_$returns_string (sci_ptr, amu_info_ptr, 1, 99, log_seg_ptr, log_mess_len, code); if code ^= 0 then do; call ssu_$release_temp_segment(sci_ptr, log_seg_ptr); return; end; call ioa_$nnl ("Syserr message:^/^3x^a", log_mess); call ssu_$release_temp_segment(sci_ptr, log_seg_ptr); end; call ioa_ ("^/^2x^a^/stack frame at ^p", amu_$get_name (amu_info_ptr, stack_frame.entry_ptr), real_ptr (sp)); call check_next; bound_comp_name = amu_$get_name (amu_info_ptr, stack_frame.return_ptr); if check_err_sw then do; skip_frame: if (index(bound_comp_name,"wire_stack") ^= 0) | (index(bound_comp_name, "pl1_operator") ^= 0) then do; call check_next; bound_comp_name = amu_$get_name (amu_info_ptr, stack_frame.return_ptr); goto skip_frame; end; end; tell_called_by: call ioa_ ("^/^2xcalled by ^p^2x^a^/at stack frame ^p", stack_frame.return_ptr, bound_comp_name,real_ptr (sp)); call savex_stack_; call check_page_err; if pg_err then do; call check_next; goto tell_called_by; end; call ioa_ ("^3xSetting frame ptr (prfr) to ^p", real_ptr (sp)); call amu_$definition_set_prn (amu_info_ptr, "prfr", fixed (baseno (real_ptr (sp)), 17), fixed (rel (real_ptr (sp)), 18), code); if code ^= 0 then return; return; end; call check_next; end; code = amu_et_$entry_not_found; return; end common_check_entry; %page; check_page_err: proc; if index (bound_comp_name, "$page_error") ^= 0 then do; if pg_err then do; call ioa_ ("ENTRY PTR ^p ^a", stack_frame.entry_ptr, amu_$get_name (amu_info_ptr, stack_frame.entry_ptr)); call display_page_err_regs; call ioa_ ("Setting temporary pointer regs from ^p", real_ptr (sp)); call amu_$definition_set_from (amu_info_ptr, "prs", sp, code); pg_err = "0"b; end; else pg_err = "1"b; end; end check_page_err; %page; display_args: proc; /* this will display the args for this frame */ if no_arg_ptr then return; /* do not print the args for this frame */ if addr (stack_frame.entry_ptr) -> its.its_mod = ITS_MODIFIER then if addr (stack_frame.entry_ptr) -> its.segno ^= "0"b then if stack_frame.entry_ptr ^= null then call ioa_ ("^/^-Entry ptr ^p ^a", stack_frame.entry_ptr, amu_$get_name (amu_info_ptr, stack_frame.entry_ptr)); if addr (stack_frame.operator_and_lp_ptr) -> its.its_mod = ITS_MODIFIER then if addr (stack_frame.operator_and_lp_ptr) -> its.segno ^= "0"b then if stack_frame.operator_and_lp_ptr ^= null then call ioa_ ("^-Operator/Link ptr ^p", stack_frame.operator_and_lp_ptr); if addr (stack_frame.arg_ptr) -> its.its_mod = ITS_MODIFIER then if addr (stack_frame.arg_ptr) -> its.segno ^= "0"b then if stack_frame.arg_ptr ^= null then do; call ioa_ ("^-Arg ptr ^p ", stack_frame.arg_ptr); call print_args; return; end; call ioa_ ("^-Arg ptr ^p invalid^/", stack_frame.arg_ptr); end display_args; %page; display_frame: proc; /* This will display the oct dump of the frame */ call amu_$print_dump_oct (sp, fixed (rel (sp), 18), (fixed (rel (stack_frame.next_sp), 18) - fixed (rel (sp), 18))); call ioa_ ("^/"); return; end display_frame; %page; display_page_err_regs: proc; temp_word = "0"b; page_err_regs.pg_ptr = sp -> mc.prs; page_err_regs.ou_regs = addrel (sp, 32) -> based_regs; arg_bits_ptr = addr (temp_word); arg_bits_def.prs, arg_bits_def.regs = "1"b; call ioa_ ("REGS saved by page_error:"); call azm_display_mc_$regs_only (sci_ptr, amu_info_ptr, addr (page_err_regs), arg_bits_ptr, code); end display_page_err_regs; %page; frame_args_: proc; dcl (xargp, ret_arg_ptr) ptr; unspec (ap), unspec (its_ptr) = unspec (stack_frame.arg_ptr); t_args_p (*) = null; /* Extract argument ptr. */ if its_ptr.its_mod ^= ITS_MODIFIER /* use valid pl1 code */ then go to badap; if ap = null then do; badap: if addr (sp -> stack_frame.entry_ptr) -> its.its_mod = ITS_MODIFIER then if sp -> stack_frame.entry_ptr ^= null then do j = 1 to hbound (begin_block_entries, 1); if addrel (sp -> stack_frame.entry_ptr, 1) -> based_bit = begin_block_entries (j) then do; call ioa_ ("^-Begin block; no arguments."); return; end; end; call ioa_ ("^-Bad argument pointer."); return; end; call amu_$do_translation_hunt_ptr (amu_info_ptr, stack_frame.arg_ptr, ap, code); if code ^= 0 then do; call amu_$error_for_caller (amu_info_ptr, code, P_caller, "translate segment ^p", stack_frame.arg_ptr); code = 0; return; end; no_args = ap->command_name_arglist.arg_count; /* get the number of arguments */ no_desc = ap->command_name_arglist.desc_count; /* and the number of descriptors */ if ^valid_arg_list () then do; call ioa_ ("^-Arg list header invalid"); code = 0; return; end; arg_list_length = (no_args + no_desc + 1) * 2; if no_args = 0 then do; /* check for no arguments */ call ioa_ ("^-No arguments."); return; end; ap = addr (t_args_p); call amu_$do_translation_by_ptr (amu_info_ptr, stack_frame.arg_ptr, arg_list_length, ap, code); if code ^= 0 then do; call amu_$error_for_caller (amu_info_ptr, code, P_caller, "Segment pointer ^p", stack_frame.arg_ptr); code = 0; return; end; if baseno (stack_frame.entry_ptr) ^= "0"b then do; call amu_$do_translation_hunt_ptr (amu_info_ptr, stack_frame.entry_ptr, temp_entry_ptr, code); if code ^= 0 then do; if code = error_table_$seg_not_found then do; temp_entry_ptr = stack_frame.entry_ptr; code = 0; end; else do; call amu_$error_for_caller (amu_info_ptr, code, P_caller, "Entry ptr ^p. Unable to determine arguments.", stack_frame.entry_ptr); code = 0; return; end; end; call get_entry_arg_descs_ (temp_entry_ptr, xnargs, xdesc, code); if code ^= 0 then do; code = 0; xnargs = 0; end; end; else xnargs = 0; if no_args > 64 then do; call ioa_ ("^-Only first 64 args of ^d will be listed.", no_args); no_args = 64; if xnargs > 64 then xnargs = 64; if no_desc ^= 0 then no_desc = 64; end; min_arg = 1; /* print out all arguments */ max_arg = no_args; max_words = 100; call condition_ ("any_other", intproc); argp = addr (temp_arg.a_buf); do j = min_arg to max_arg; /* loop through the desired number of args */ temp_arg_ptr = ap -> ptr_array (j); /* get pointer to the argument */ if temp_arg_ptr ^= null then do; /* now get the arg data 100 words should do it */ call amu_$do_translation_hunt (amu_info_ptr, fixed(baseno(temp_arg_ptr),17), addr (temp_arg.a_buf), fixed(rel(temp_arg_ptr),18), max_words, code); if code ^= 0 then do; call ioa_ ("^-ARG ^2d: Cannot get data at ^p^/^-^7x^a", j, temp_arg_ptr, amu_$get_name (amu_info_ptr, temp_arg_ptr)); code = 0; goto skiparg; end; end; else do; /* pointer to arg = null */ call ioa_ ("^-ARG ^2d: pointer to this arg is null ", j); goto skiparg; end; if no_desc ^= 0 then do; /* if we have descriptors, look at them */ /* get the pointer to the descriptor */ if ap->arg_list_with_envptr.call_type = Envptr_supplied_call_type then jd = j+1; else jd = j; if t_args_p (no_args + jd) = null then goto guess; call amu_$do_translation_hunt_ptr (amu_info_ptr, t_args_p (no_args + jd), temp_desc_ptr, code); if code ^= 0 then do; code = 0; goto guess; end; call decode_descriptor_ (temp_desc_ptr, 0, type, packed, ndims, strl, scale); /* Does procedure expect arguments? */ if xnargs >= j then /* Yes. Do we know what this arg should be? */ if xdesc (jd) ^= null then do; call amu_$do_translation_hunt_ptr (amu_info_ptr, pointer (stack_frame.entry_ptr, fixed (rel (xdesc (jd)), 18)), tdesc (jd), code); if code ^= 0 then do; call amu_$error_for_caller (amu_info_ptr, code, P_caller, "translate xdesc ^p", xdesc (jd)); code = 0; return; end; call decode_descriptor_ (tdesc (jd), 0, xtype, xpacked, xndims, xstrl, xscale); if xtype ^= type then do; if type >= lbound (data_type_info_$info, 1) & type <= hbound (data_type_info_$info, 1) then ttype = rtrim(type_name (type)); else call ioa_$rsnnl ("type ^d", ttype, k, type); if xtype >= lbound (data_type_info_$info, 1) & xtype <= hbound (data_type_info_$info, 1) then xttype = rtrim(type_name (xtype)); else call ioa_$rsnnl ("type ^d", xttype, k, xtype); end; end; end; else do; /* try to find out what type by heuristics */ guess: packed = "0"b; scale = 0; ndims = 0; if addr (temp_arg.a_buf (1)) -> its.its_mod = ITS_MODIFIER then type = pointer_dtype; /* assume pointer */ else do; strl = verify (bcs, LEGAL) - 1; /* Scan for last legal char in string. */ if strl < 0 then strl = 100; /* If all legal, print first 100. */ if strl >= 2 then type = char_dtype; else type = -1; /* full word octal */ end; end; call check_bit_offset (temp_arg_ptr, argp, ret_arg_ptr); if ret_arg_ptr ^= null then do; xargp = argp; argp = ret_arg_ptr; end; if type = varying_bit_dtype | type = varying_char_dtype then do; /* get the length */ call amu_$do_translation_hunt (amu_info_ptr, fixed (baseno (argp), 17), addrel (addr (temp_arg.a_buf), -1), (fixed (rel (argp), 18) - 1), 1, code); if code ^= 0 then do; call ioa_ ("^-ARG ^2d: ^w", j, fword (1)); code = 0; goto skiparg; end; end; if type = -1 then call ioa_ ("^-ARG ^2d: ^w", j, fword (1)); /* no descriptor; print full word octal */ else if type < lbound (data_type_info_$info, 1) | type > hbound (data_type_info_$info, 1) then call ioa_ ("^-ARG ^2d: (bad type ^d at ^p) ^w", j, type, argp, temp_arg.a_buf (1)); else if data_type_info_$info (type).arithmetic then do; call arithmetic_to_ascii_ (argp, type, packed, strl, scale, ascii_representation); call ioa_ ("^-ARG ^2d: ^a", j, ascii_representation); end; else if type = pointer_dtype then do; /* Pointer */ if packed then do; /* packed ptr */ tp = argp -> packptr; go to pptr; end; if argp -> its.its_mod = ITS_MODIFIER then do; tp = argp -> ptr_array (0); pptr: call ioa_ ("^-ARG ^2d: ^p ^a", j, tp, amu_$get_name (amu_info_ptr, tp)); end; else call ioa_ ("^-ARG ^2d: ^w ^w", j, fword (1), fword (2)); end; else if type = offset_dtype /* Offset */ then call ioa_ ("^-ARG ^2d: ^w", j, fword (1)); else if type = label_dtype | type = entry_dtype /* Label, Entry */ then do; call ioa_ ("^-ARG ^2d: ^p ^a", j, label_variable.ptr, amu_$get_name (amu_info_ptr, argp->label_variable.ptr)); end; else if type = bit_dtype | type = varying_bit_dtype /* Bit string */ then do; if type = varying_bit_dtype then strl = addrel (argp, -1) -> fword (1); c75 = """"; /* initial quote */ k = 0; /* count 1-bits */ do i = 1 to min (strl, 72); if substr (bit_string, i, 1) then do; k = k + 1; substr (c75, i + 1, 1) = "1"; end; else substr (c75, i + 1, 1) = "0"; end; substr (c75, i + 1, 2) = """b"; if (strl <= 72 & strl > 1) then /* Maybe compress representation */ if k = 0 then call ioa_$rsnnl ("(^d)""0""b", c75, k, strl); else if k = strl then call ioa_$rsnnl ("(^d)""1""b", c75, k, strl); call ioa_ ("^-ARG ^2d: ^a", j, c75); end; else if type = char_dtype | type = varying_char_dtype /* Character string */ then do; if type = varying_char_dtype then strl = min (80, max (addrel (argp, -1) -> fword (1), 0)); call ioa_ ("^-ARG ^2d: ""^va""", j, strl, char_string); end; else if type = file_dtype /* File */ then do; call ioa_ ("^-ARG ^2d: ", j); end; else call ioa_ ("^-ARG ^2d: (^a at ^p) ^w", j, type_name (type), argp, fword (1)); if ndims > 0 then call ioa_ ("^-^-(^d-dim array)", ndims); if ret_arg_ptr ^= null then argp = xargp; skiparg: end; /* ------------------------------------------------------- */ intproc: proc (mcp, cname, cop, infop, cont); dcl (mcp, cop, infop) ptr, cname char (*), cont bit (1); /* format: ^delnl */ if cname = "program_interrupt" | cname = "finish" | cname = "quit" then do; cont = "1"b; return; end; /* format: revert */ if cname = "cleanup" then return; if infop ^= null then if infop -> condition_info_header.action_flags.quiet_restart then return; call ioa_ ("^-ARG ^2d not accessible. - ^a", j, cname); go to skiparg; end; end frame_args_; %page; valid_arg_list: proc returns (bit (1)); if ap->command_name_arglist.mbz ^= "0"b then return ("0"b); if ap->command_name_arglist.call_type ^= Interseg_call_type then if ap->command_name_arglist.call_type ^= Envptr_supplied_call_type then if ap->command_name_arglist.call_type ^= Quick_call_type then return ("0"b); if no_desc ^= 0 then if no_desc ^= no_desc then return ("0"b); return ("1"b); end valid_arg_list; %page; check_bit_offset: proc (P_temp_arg_ptr, P_argp, P_ret_arg_ptr); dcl (P_temp_arg_ptr, P_argp, P_ret_arg_ptr) ptr parameter; /* Check for existence of a ptr offset NOT specifying beginning of octal word boundary. */ P_ret_arg_ptr = null; if addr(P_temp_arg_ptr) -> its.bit_offset ^= ""b then do; P_ret_arg_ptr = P_argp; addr(P_ret_arg_ptr) -> its.bit_offset = addr(P_temp_arg_ptr) -> its.bit_offset; end; return; end check_bit_offset; %page; get_new_trans: proc; /* get a translation for the seg and place / replace it in the translation table */ translation_ptr = addr (temp_trans); if amu_info.type = FDUMP_PROCESS_TYPE then do; if ^amu_$return_val_per_process (amu_info_ptr, segno) then do; /* could be stack for logger */ temp_proc_hold = amu_info.process_idx; call amu_$fdump_mpt_change_idx (amu_info_ptr, 0); call amu_$fdump_translate_to_temp_seg (amu_info_ptr, baseptr (segno), translation_ptr, code); call amu_$fdump_mpt_change_idx (amu_info_ptr, temp_proc_hold); end; else do; call amu_$fdump_translate_to_temp_seg (amu_info_ptr, baseptr (segno), translation_ptr, code); end; end; else if amu_info.type = SAVED_PROC_TYPE then do; code = amu_et_$no_translation; return; end; else do; code = amu_et_$not_implemented; return; end; if code ^= 0 then do; P_code = code; return; end; call amu_$translate_force_add (amu_info_ptr, translation_ptr, segno, code); if code ^= 0 then do; P_code = code; return; end; end get_new_trans; %page; get_stack: proc; sb = pointer (stack_ptr, 0); segno = fixed (baseno (sb), 17); stack_offset = fixed (rel (stack_ptr), 18); /* see if this segno for this Process and erf is translated */ call amu_$translate_get (amu_info_ptr, segno, translation_ptr, code); if translation_ptr = null then do; /* if null then no trans */ if code = amu_et_$invalid_segno then do;/* not valid segno */ P_code = code; return; end; else do; /* OK now translate it into a temp seg */ call get_new_trans; if code ^= 0 then do; P_code = code; return; end; end; end; else do; /* if translated see if it is in a temp seg */ if ^translation.flags.in_temp_seg & ^translation.flags.in_perm_seg then do; /* is not in a temp seg so retranslate it */ call get_new_trans; if code ^= 0 then do; P_code = code; return; end; end; end; sb = translation.part1.ptr; if ^thread_ptr_val (stack_header.stack_begin_ptr, "1"b) then code = amu_et_$not_stack_seg; else if ^thread_ptr_val (stack_header.stack_end_ptr, "1"b) then code = amu_et_$not_stack_seg; end get_stack; %page; mc_frame: proc (set_for); dcl set_for bit (1); dcl mcp ptr; dcl out char (168); out = amu_$get_name (amu_info_ptr, stack_frame.return_ptr); if index (out, "return_to_ring_") ^= 0 | index (out, "$fim|") ^= 0 then do; number_mcs = number_mcs + 1; call ioa_ ("FIM FRAME found at ^p", real_ptr (sp)); mcp = addrel (sp, 48); temp_word = "0"b; arg_bits_ptr = addr (temp_word); arg_bits_def.set_ptr = set_for; arg_bits_def.ppr, arg_bits_def.tpr, arg_bits_def.pr (6) = "1"b; call ioa_ ("Machine Conditions at ^p: ", real_ptr (mcp)); call azm_display_mc_ (sci_ptr, amu_info_ptr, mcp, arg_bits_ptr, code); if code ^= 0 then call amu_$error_for_caller (amu_info_ptr, code, P_caller); if set_for then do; call ioa_ ("Setting temporary pointers from machine conditions at ^p", real_ptr (mcp)); call amu_$definition_set_prn (amu_info_ptr, "prmc", fixed (baseno (real_ptr (mcp)), 17), fixed (rel (real_ptr (mcp)), 18), code); if code ^= 0 then call amu_$error_for_caller (amu_info_ptr, code, P_caller); call amu_$definition_set_from (amu_info_ptr, "prs", mcp, code); if code ^= 0 then call amu_$error_for_caller (amu_info_ptr, code, P_caller); call amu_$definition_set_prn (amu_info_ptr, "prfr", fixed (baseno (real_ptr (sp)), 17), fixed (rel (real_ptr (sp)), 18), code); if code ^= 0 then call amu_$error_for_caller (amu_info_ptr, code, P_caller); end; no_arg_ptr = "1"b; /* do not try to print the args for this frame */ end; return; end mc_frame; %page; print_args: proc; if addr (stack_frame.arg_ptr) -> its.its_mod = ITS_MODIFIER then if addr (stack_frame.arg_ptr) -> its.segno ^= "0"b then if stack_frame.arg_ptr ^= null then do; call frame_args_; call ioa_ (" "); return; end; call ioa_ ("Arg_ptr invalid ^p^/", stack_frame.arg_ptr); end print_args; %page; real_ptr: proc (given_p) returns (ptr); dcl temp_ptr ptr; dcl given_p ptr; temp_ptr = pointer (baseptr (segno), fixed (rel (given_p), 18)); return (temp_ptr); end real_ptr; %page; savex_stack_: proc; dcl 1 save_stack (20) based (stackp), 2 upper fixed bin (17) unal, 2 lower fixed bin (17) unal; dcl stackp ptr; dcl num_based fixed bin unal based; dcl print_savex bit (1); dcl (number, id_offset, i, rel_offset, stack_size) fixed bin; dcl temp_name_ptr ptr; dcl segno fixed bin (17); print_savex = "0"b; segno = fixed (baseno (stack_frame.return_ptr), 17); if segno = fixed (baseno (pxss_ptr), 17) then do; call azm_ret_x7_stack_$pxss (rel_offset, id_offset, stack_size); print_savex = "1"b; end; if segno = fixed (baseno (page_ptr), 17) then do; call azm_ret_x7_stack_$page (rel_offset, id_offset, stack_size); print_savex = "1"b; end; if ^print_savex then return; stackp = addrel (sp, rel_offset); number = addrel (sp, id_offset) -> num_based - fixed (rel (stackp), 17); if (number > 0) & (number <= stack_size) then call ioa_ ("^2-savex_stack at ^p, stack_size ^o, valid ^o", real_ptr (stackp), stack_size, number); else return; do i = number by -1 to 1; temp_name_ptr = pointer (baseptr (segno), save_stack (i).upper); call ioa_ ("^2-^3x^o^3x^a", save_stack (i).upper, amu_$get_name (amu_info_ptr, temp_name_ptr)); end; end savex_stack_; %page; set_up_search: proc; amu_info_ptr = P_amu_info_ptr; frames_fwd_ptr, frames_rev_ptr = null (); stack_ptr = P_stack_ptr; call get_stack; if code ^= 0 then return; for_number = 0; sp = pointer (sb, fixed (rel (stack_header.stack_begin_ptr), 18)); if fixed (rel (sp), 18) >= fixed (rel (stack_header.stack_end_ptr), 18) then do; code = amu_et_$no_valid_stacks; return; end; stack_frames_fwd, stack_frames_rev = 0; call CHECK_THREAD; if code ^= 0 then goto ERROR; stop = "0"b; frame_number = 0; end set_up_search; %page; thread_ptr_val: proc (vptr, segno_check) returns (bit (1)); dcl vptr ptr; dcl segno_check bit (1); dcl ret_bit bit(1); dcl any_other condition; ret_bit="0"b; on condition (any_other) begin; goto RET_VAL; end; if addr (vptr) -> its.its_mod = ITS_MODIFIER then if segno_check then if segno = fixed (baseno (vptr), 17) then ret_bit= "1"b; else ret_bit= "0"b; else ret_bit = "1"b; else ret_bit ="0"b; revert any_other; RET_VAL: return(ret_bit); end thread_ptr_val; %page; %include amu_info; %page; %include amu_mc; %page; %include amu_translation; %page; %include arg_list; %page; %include condition_info_header; %page; %include data_type_info_; %page; %include its; %page; %include mc; %page; %include probe_data_type_names; %page; %include stack_frame; %page; %include stack_header; %page; %include std_descriptor_types; end azm_stack_trace_;  azm_str_util_.pl1 11/19/84 1143.5rew 11/15/84 1440.2 34272 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ azm_str_util_: proc (P_amu_info_ptr, P_strp, P_code); /* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */ dcl P_amu_info_ptr ptr; dcl P_strp bit (18); dcl P_code fixed bin (35); dcl code fixed bin (35); dcl save_process_index fixed bin; dcl loop_exit bit (1); dcl exit_sw bit (1); dcl 1 seg_trailer like str; dcl str_size fixed bin (18); dcl seg_name char (32); dcl str_segno fixed bin; dcl offset fixed bin (18); dcl pds_dstep ptr; dcl 1 hard_cur like hardcore_cur; dcl temp_dstep bit (18); dcl temp_indx fixed bin; dcl amu_$definition_ptr entry (ptr, char (*), char (*), fixed bin (35)) returns (ptr); dcl amu_$do_translation entry (ptr, fixed bin, ptr, fixed bin (18), fixed bin (18), fixed bin (35)); dcl amu_$do_translation_by_ptr entry (ptr, ptr, fixed bin (18), ptr, fixed bin (35)); dcl amu_$fdump_mpt_change_idx entry (ptr, fixed bin); dcl amu_$hardcore_info_set_cur_ptrs entry (ptr, ptr); dcl amu_$slt_search_seg_num entry (ptr, ptr, char (32), fixed bin, fixed bin (35)); dcl amu_$fdump_mpt_current_process entry (ptr); dcl ioa_$nnl entry () options (variable); dcl (addr, fixed, hbound, size) builtin; amu_info_ptr = P_amu_info_ptr; offset = fixed (P_strp, 18); if offset = 0 then return; save_process_index = amu_info.process_idx; /* change to first process in fdump */ call amu_$fdump_mpt_change_idx (amu_info_ptr, 0); hardcore_cur_ptr = addr (hard_cur); call amu_$hardcore_info_set_cur_ptrs (amu_info_ptr, hardcore_cur_ptr); /* now get the str_seg data */ seg_name = "str_seg"; call amu_$slt_search_seg_num (hard_cur.sltp, hard_cur.sltntp, seg_name, str_segno, code); if code ^= 0 then goto str_exit; str_size = size (str); strp = addr (seg_trailer); call amu_$do_translation (amu_info_ptr, str_segno, strp, offset, str_size, code); if code ^= 0 then goto str_exit; /* now find the first process that this seg known to */ do while (str.bp ^= "0"b); offset = fixed (str.bp, 18); call amu_$do_translation (amu_info_ptr, str_segno, strp, offset, str_size, code); if code ^= 0 then do; P_code = code; return; end; end; /* get pointer of prds$dstep */ pds_dstep = amu_$definition_ptr (amu_info_ptr, "pds", "dstep", code); if code ^= 0 then do; P_code = code; return; end; /* now start walking the str thread matching up str.dstep with pds$dstep */ exit_sw = "0"b; do while (exit_sw = "0"b); loop_exit = "0"b; do temp_indx = 0 to hbound (fdump_process_table.array, 1) while (^loop_exit); call amu_$fdump_mpt_change_idx (amu_info_ptr, temp_indx); call amu_$do_translation_by_ptr (amu_info_ptr, pds_dstep, 1, addr (temp_dstep), code); if code ^= 0 then goto str_exit; if temp_dstep = str.dstep /* found a process */ then do; loop_exit = "1"b; call ioa_$nnl ("^o in ", str.segno); call amu_$fdump_mpt_current_process (amu_info_ptr); end; end; call amu_$fdump_mpt_change_idx (amu_info_ptr, save_process_index); if str.fp = "0"b then exit_sw = "1"b; else do; offset = fixed (str.fp, 18); call amu_$do_translation (amu_info_ptr, str_segno, strp, offset, str_size, code); if code ^= 0 then goto str_exit; end; end; str_exit: call amu_$fdump_mpt_change_idx (amu_info_ptr, save_process_index); P_code = code; return; %page; %include amu_fdump_info; %page; %include amu_hardcore_info; %page; %include amu_info; %page; %include str; end azm_str_util_;  azm_syserr_.pl1 07/28/87 0939.2rew 07/28/87 0930.0 168957 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-01-15,Farley), approve(87-07-09,MCR7746), audit(87-07-16,Fawcett), install(87-07-28,MR12.1-1049): Changed to properly set P_ret_len when exiting, when entered at returns_string. END HISTORY COMMENTS */ azm_syserr_: proc; return; /* * 84-12-15, W. Olin Sibert: Converted (albeit with a monstrous kludge) * for new-format log segments in the partition. */ /* Modified 01/21/85, B. Braun to a) call print_sys_log with a severity specified. b) change the data and log entries to require a char severity range instead of fixed bin. c) delete the $code_only entry as it apparently isn't referenced by anyone. d) Set severity for returns_string entry in case it goes to the log. */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */ /* Parameters */ dcl P_amu_info_ptr ptr; dcl P_sci_ptr ptr; dcl P_code fixed bin (35); dcl P_count fixed bin (35); dcl P_match_str char (*) var; dcl P_match_sw bit (1); dcl P_expand_sw bit (1); dcl P_syserr_code fixed bin; dcl P_severity char(*) var; dcl P_string_len fixed bin (21); dcl P_string_ptr ptr; dcl amu_$hardcore_info_set_cur_ptrs entry (ptr, ptr); dcl amu_$slt_search_seg_num entry (ptr, ptr, char (32) aligned, fixed bin, fixed bin (35)); dcl amu_$definition_ptr entry (ptr, char (*), char (*), fixed bin (35)) returns (ptr); dcl amu_$do_translation entry (ptr, fixed bin, ptr, fixed bin (18), fixed bin (18), fixed bin (35)); dcl azm_display_mc_ entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl ioa_ entry () options (variable); dcl ioa_$rs entry() options(variable); dcl ssu_$get_temp_segment entry (ptr, char(*), ptr); dcl ssu_$release_temp_segment entry (ptr, ptr); dcl print_syserr_msg_ entry (ptr, fixed bin (35)); dcl iox_$user_output ptr ext static; dcl get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin); dcl date_time_ entry (fixed bin (71), char (*)); dcl amu_$hranl entry (ptr, ptr, bit (1)); /* Builtins */ dcl (addr, addrel, baseno, char, fixed, index, null, rel, rtrim, size, substr, unspec) builtin; /* Handlers */ dcl cleanup condition; /* Automatic */ dcl a_syserr_code fixed bin; dcl data_area_ptr ptr; dcl mess_count fixed bin; dcl head_size fixed bin; dcl severity char(30); dcl segno fixed bin (17); dcl (offset, range) fixed bin (18); dcl (code, def_code) fixed bin (35); dcl w_header (size (wlog_header)) fixed bin; dcl 1 current_hardcore like hardcore_cur; dcl i fixed bin; dcl new_time char (24); dcl 1 auto_parg like parg aligned automatic; dcl plural_sw bit (1) init ("0"b); dcl (msgs_printed, msgs_bypassed) fixed bin init (0); dcl text char (512); dcl msg_printed bit (1); dcl code_only_sw bit (1); dcl found_one_sw bit (1); dcl returns_sw bit (1); dcl ret_len fixed bin (21); dcl foo_len fixed bin (21); dcl ret_string_ptr ptr; dcl ret_data char (ret_len) based (ret_string_ptr); dcl sci_ptr ptr; %page; returns_string: entry (P_sci_ptr,P_amu_info_ptr, P_syserr_code, P_count, P_string_ptr,P_string_len,P_code); ret_string_ptr = P_string_ptr; ret_len = 0; returns_sw = "1"b; amu_info_ptr = P_amu_info_ptr; sci_ptr = P_sci_ptr; a_syserr_code = P_syserr_code; severity = char(a_syserr_code); /* Need this if we get to code_from_log */ code_only_sw = "1"b; mess_count = P_count; found_one_sw = "0"b; goto code_from_data; check_if_found: if returns_sw then P_string_len = ret_len; P_code = 0; return; %page; data: entry (P_sci_ptr, P_amu_info_ptr, P_count, P_match_str, P_match_sw, P_expand_sw, P_severity, P_code); amu_info_ptr = P_amu_info_ptr; sci_ptr = P_sci_ptr; severity = substr(P_severity,1); code_only_sw,returns_sw = "0"b; mess_count = P_count; code_from_data: wmess_ptr = null (); on condition(cleanup) begin; if wmess_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, wmess_ptr); end; data_area_ptr = amu_$definition_ptr (amu_info_ptr, "syserr_data", "wired_log_area", def_code); head_size = size (wlog_header); wlog_ptr = addr (w_header); segno = fixed (baseno (data_area_ptr), 17); offset = fixed (rel (data_area_ptr), 18); range = head_size; call amu_$do_translation (amu_info_ptr, segno, wlog_ptr, offset, range, code); if code ^= 0 then do; if returns_sw then P_string_len = ret_len; P_code = code; return; end; if wlog.count = 0 then do; if code_only_sw then goto code_from_log; call ioa_ ("No entries in syserr_data (segment #^o).", segno); goto check_if_found; end; call ssu_$get_temp_segment (sci_ptr,"azm-syserr_data", wmess_ptr); offset = offset + head_size; range = fixed (wlog.head.bsize, 18); call amu_$do_translation (amu_info_ptr, segno, wmess_ptr, offset, range, code); if code ^= 0 then do; if returns_sw then P_string_len = ret_len; P_code = code; if wmess_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, wmess_ptr); return; end; argp = addr (auto_parg); /* Get pointer to argument list */ parg.iocbp = iox_$user_output; /* Data is written here */ parg.prev_time = ""; /* Clear previous time field */ if code_only_sw then do; parg.bin_sw = "0"b; parg.octal_sw = "0"b; end; else do; parg.bin_sw = P_expand_sw; parg.octal_sw = P_expand_sw; end; parg.pad = "0"b; /* Be neat */ parg.linelen = get_line_length_$switch (iox_$user_output, code); /* Need length of line */ if code ^= 0 then parg.linelen = 132; /* Assume printer if error */ if ^code_only_sw then call ioa_ ("There ^[are^]^[is^] ^d message^[s^] in syserr_data (segment #^o).", (wlog.count > 1), (wlog.count = 1), wlog.count, (wlog.count > 1), segno); if mess_count > wlog.count | mess_count <=0 then mess_count = wlog.count; do i = 1 to mess_count; if wmess.text_len = 0 then goto skip; new_time = datm (addr (wmess.time)); if code_only_sw then do; if wmess.code ^= a_syserr_code then go to skip; syserr_msgp = addr (wmess.seq_num); if returns_sw then do; ret_len = ret_len + syserr_msg.text_len + 1; call ioa_$rs ("^a ",ret_data,foo_len, substr(syserr_msg.text,1, syserr_msg.text_len)); goto skip; end; text = syserr_msg.text; msg_printed = "0"b; found_one_sw = "1"b; goto ok_to_print_data; end; if P_match_str ^= "" then do; if index (substr (wmess.text, 1, wmess.text_len), P_match_str) = 0 then do; if P_match_sw then go to skip; end; else if ^P_match_sw then goto skip; /* excluding */ end; if wmess.code > a_syserr_code then go to skip; msg_printed = "0"b; syserr_msgp = addr (wmess.seq_num); text = syserr_msg.text; if syserr_msg.data_code = SB_hw_fault & syserr_msg.data_size > 0 then if P_expand_sw then do; call display_hw_fault (addr (syserr_msg.data)); msg_printed = "1"b; end; ok_to_print_data: parg.msgp = addr (wmess.seq_num); parg.textp = addr (text); parg.textl = syserr_msg.text_len; parg.printp = addr (text); parg.printl = syserr_msg.text_len; if ^msg_printed then call print_syserr_msg_ (argp, code); if code ^= 0 then do; if returns_sw then P_string_len = ret_len; P_code = code; return; end; skip: parg.prev_time = new_time; wmess_ptr = addr (wmess.data (wmess.data_size + 1)); end; if wmess_ptr ^= null() then call ssu_$release_temp_segment(sci_ptr, wmess_ptr); if returns_sw then P_string_len = ret_len; P_code = 0; if code_only_sw then goto code_from_log; EXIT_DATA: return; /* end of azm_syserr_$data */ %page; log: entry (P_sci_ptr, P_amu_info_ptr, P_count, P_match_str, P_match_sw, P_expand_sw, P_severity, P_code); amu_info_ptr = P_amu_info_ptr; sci_ptr = P_sci_ptr; severity = substr(P_severity,1); code_only_sw,returns_sw = "0"b; code_from_log: mess_count = P_count; hardcore_cur_ptr = addr (current_hardcore); call amu_$hardcore_info_set_cur_ptrs (amu_info_ptr, hardcore_cur_ptr); call ioa_ ("^/Syserr messages from log partition:^/"); call print_log_partition (); if returns_sw then P_string_len = ret_len; P_code = code; return; %page; /* This procedure is responsible for printing messages from the log partition. I am not proud of this implementation; it is not very flexible, it works by calling the command, possibly producing unexpected results, and is in general not very pretty. On the other hand, what it has to recommend it is that it works. I chose this approach because the interface from azm is itself not very flexible, and I didn't want to change that right at this moment. Ultimately, of course, the AZM log requests should just be direct interfaces to print_sys_log, and do no processing of their own. For the moment, though, that's too awkward, so instead we settle for this kludge. It works by copying the one or two log segments in use into temp segments, then creating links to those temp segments in the process dir, and calling print_sys_log to print the log family defined by those links to temp segs. It has various cases of calling print_sys_log depending on the options passed in from the AZM request. */ print_log_partition: procedure (); declare 1 auto_syserr_log_data aligned like syserr_log_data automatic; declare 1 log_seg (2) aligned, 2 segno fixed bin, 2 name char (32) unaligned, 2 pathname char (168) unaligned, 2 copy_ptr pointer, 2 link_dname char (168) unaligned, 2 link_ename char (32) unaligned; declare syserr_log_data_segno fixed bin; declare family_name char (32); declare log_path char (168); declare match_arg char (32); declare expand_arg char (32); declare delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35)); declare get_pdir_ entry () returns (char (168)); declare hcs_$fs_get_path_name entry (pointer, char (*), fixed bin, char (*), fixed bin (35)); declare hcs_$append_link entry (char (*), char (*), char (*), fixed bin (35)); declare log_segment_$last_message_info entry (pointer, fixed bin (35), fixed bin (18), fixed bin (35)); declare pathname_ entry (char (*), char (*)) returns (char (168)); declare unique_chars_ entry (bit (*)) returns (char (15)); declare print_sys_log entry options (variable); /* */ log_seg.copy_ptr (*) = null (); log_seg.pathname (*) = ""; log_seg.link_ename (*) = ""; log_seg.link_dname (*) = ""; on condition (cleanup) call clean_up_print_log_partition (); syserr_log_data_ptr = addr (auto_syserr_log_data); call amu_$slt_search_seg_num (hardcore_cur.sltp, hardcore_cur.sltntp, "syserr_log_data", syserr_log_data_segno, code); if (code ^= 0) then goto ERROR_RETURN; call amu_$do_translation (amu_info_ptr, syserr_log_data_segno, syserr_log_data_ptr, 0, size (syserr_log_data), code); if (code ^= 0) then goto ERROR_RETURN; if (syserr_log_data.live_log ^= 1) & (syserr_log_data.live_log ^= 2) then do; call ioa_ ("No active syserr log segment in syserr_log_data."); code = 0; goto ERROR_RETURN; end; family_name = unique_chars_ (""b); call get_log_segment (syserr_log_data.live_log, family_name); if (syserr_log_data.swap_time ^= 0) then do; /* Other one isn't empty */ family_name = rtrim (family_name) || ".19841214.164821"; call get_log_segment ((3 - syserr_log_data.live_log), (rtrim (family_name) || ".19841214.214821")); end; log_path = pathname_ (log_seg.link_dname (syserr_log_data.live_log), log_seg.link_ename (syserr_log_data.live_log)); if P_match_sw then match_arg = "-match"; else match_arg = "-exclude"; if P_expand_sw then expand_arg = "-expand"; else expand_arg = "-no_expand"; if (mess_count > 0) then if (P_match_str ^= "") then call print_sys_log (log_path, "-reverse", "-no_header", "-date_format", "", expand_arg, "-severity", severity, "-last", char (mess_count), match_arg, substr (P_match_str, 1)); else call print_sys_log (log_path, "-reverse", "-no_header", "-date_format", "", expand_arg, "-severity", severity, "-last", char (mess_count)); else if (substr (P_match_str, 1) ^= "") then call print_sys_log (log_path, "-reverse", "-no_header", "-date_format", "", expand_arg, "-severity", severity, match_arg, substr (P_match_str, 1)); else call print_sys_log (log_path, "-reverse", "-no_header", "-date_format", "", expand_arg, "-severity", severity); code = 0; /* Indicate success */ ERROR_RETURN: call clean_up_print_log_partition (); return; /* */ get_log_segment: procedure (P_idx, P_link_name); declare P_idx fixed bin parameter; declare P_link_name char (*) parameter; declare log_name char (32); declare last_offset fixed bin (18); declare dname char (168); declare ename char (32); /* This procedure copies a syserr log segment into a temp segment, and makes a link to that temp segment in order to use it as input to print_sys_log. First, it determines the log name, acquires the temp segment, and records its pathname. */ if (P_idx = 1) then log_name = "syserr_log_laurel"; else log_name = "syserr_log_hardy"; call ssu_$get_temp_segment (sci_ptr, ("azm-" || log_name), log_seg.copy_ptr (P_idx)); call hcs_$fs_get_path_name (log_seg.copy_ptr (P_idx), dname, (0), ename, code); if (code ^= 0) then goto ERROR_RETURN; log_seg.pathname (P_idx) = pathname_ (dname, ename); /* Next, it finds the segment in the dump address space */ call amu_$slt_search_seg_num (hardcore_cur.sltp, hardcore_cur.sltntp, (log_name), log_seg.segno (P_idx), code); if (code ^= 0) then goto ERROR_RETURN; /* Now, copy the contents of the header, figure out how much is actually in use, and then copy the whole of the in-use object. */ call amu_$do_translation (amu_info_ptr, log_seg.segno (P_idx), log_seg.copy_ptr (P_idx), 0, size (log_segment_header), code); if (code ^= 0) then goto ERROR_RETURN; log_segment_ptr = log_seg.copy_ptr (P_idx); call log_segment_$last_message_info (log_segment_ptr, (0), last_offset, code); if (code ^= 0) then goto ERROR_RETURN; if (last_offset <= size (log_segment_header)) then return; call amu_$do_translation (amu_info_ptr, log_seg.segno (P_idx), addrel (log_seg.copy_ptr (P_idx), size (log_segment_header)), size (log_segment_header), (last_offset - size (log_segment_header)), code); if (code ^= 0) then goto ERROR_RETURN; log_seg.link_dname (P_idx) = get_pdir_ (); log_seg.link_ename (P_idx) = P_link_name; call hcs_$append_link (log_seg.link_dname (P_idx), log_seg.link_ename (P_idx), log_seg.pathname (P_idx), code); if (code ^= 0) then goto ERROR_RETURN; return; end get_log_segment; /* */ clean_up_print_log_partition: procedure (); if (log_seg.link_dname (1) ^= "") then call delete_$path (log_seg.link_dname (1), log_seg.link_ename (1), "000010"b, "", (0)); if (log_seg.link_dname (2) ^= "") then call delete_$path (log_seg.link_dname (2), log_seg.link_ename (2), "000010"b, "", (0)); if (log_seg.copy_ptr (1) ^= null ()) then call ssu_$release_temp_segment (sci_ptr, log_seg.copy_ptr (1)); if (log_seg.copy_ptr (2) ^= null ()) then call ssu_$release_temp_segment (sci_ptr, log_seg.copy_ptr (2)); return; end clean_up_print_log_partition; end print_log_partition; datm: proc (tp) returns (char (24) aligned); dcl tp ptr; /* pointer to time value to convert */ dcl timcv fixed bin (71); dcl timein (2) fixed bin (35) based (tp); dcl timeint (2) fixed bin (35) based (addr (timcv)); dcl timout char (24); timeint = timein; /* Copy time value to assure even boundary */ call date_time_ (timcv, timout); return (timout); end datm; %page; display_hw_fault: proc (fault_msgp); dcl hr_ptr ptr; dcl fault_msgp ptr; dcl my_mcp ptr; dcl 1 a_arg_bits_def like arg_bits_def; dcl 1 fault_msg aligned, 2 mcx like mc aligned; dcl 1 fault_msg1 aligned based (fault_msgp), 2 mcy like mc aligned, 2 hisregs (128) bit (36) aligned; /* set up to display all MC data */ a_arg_bits_def.dump, a_arg_bits_def.mc_stored, a_arg_bits_def.long = "0"b; a_arg_bits_def.all = "1"b; arg_bits_ptr = addr (a_arg_bits_def); mcp = fault_msgp; hr_ptr = addr (fault_msg1.hisregs); /* Copy the data over to auto. This is necessary as the PRs in syserr are not on even word boundaries. */ mcx = mc; unspec (mcx.prs) = unspec (mc.prs); my_mcp = addr (fault_msg); call azm_display_mc_ (sci_ptr, amu_info_ptr, my_mcp, arg_bits_ptr, code); call ioa_ ("^/History Register Data:^/"); call amu_$hranl (hr_ptr, null, "0"b); call ioa_ ("^/"); msgs_printed = msgs_printed + 1; return; end display_hw_fault; %page; %include amu_info; %page; %include syserr_log_dcls; %page; %include log_segment; %page; %include log_message; %page; %include syserr_data; %page; %include syserr_binary_def; %page; %include print_syserr_msg_args; %page; %include syserr_message; %page; %include amu_hardcore_info; %page; %include mc; %page; %include amu_mc; end azm_syserr_;  azm_verify_dump_ams_.pl1 07/28/87 0939.2rew 07/28/87 0930.0 142101 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-07-09,Parisek), approve(87-07-09,MCR7746), audit(87-07-16,Fawcett), install(87-07-28,MR12.1-1049): Changed references of BOS CPU to Bootload CPU. END HISTORY COMMENTS */ azm_verify_dump_ams_: proc (P_amu_info_ptr, do_sdws, do_ptws, P_code); /* format: style4,delnl,insnl,ifthenstmt,indnoniterend,ifthendo,ifthen,^thendo */ /* Routine to verify that the contents of the Associative Memories stored at the time of the dump match the appropriate entries in the dseg of the process defined by dump.dbr. This code was taken from ol_dumps display_am_$validate_am_btld and modified to work with analyze_multics (azm). Sept 1982 by Rich Coppola. Modified July 84 by B. Braun to add knowledge of unpaged_page_tables. Modified Sept 84 by B. Braun to add knowledge of int_unpaged_page_tables. */ dcl P_amu_info_ptr ptr; dcl (do_sdws, do_ptws) bit (1); dcl P_code fixed bin (35); /* Automatic */ dcl (i, j, idx, process_idx) fixed bin; dcl af_sw bit (1) init ("0"b); /* "1"b => used as an AF */ dcl nregs fixed bin; dcl dump_dbr fixed bin (24); dcl code fixed bin (35); dcl DPS8xxM bit (1); dcl RETURN_VAL bit (1) init ("0"b); dcl (found_mismatch_sdw, found_mismatch_ptw) bit (1) init ("0"b); dcl (found_dup_entry_sdw, found_dup_entry_ptw) bit (1) init ("0"b); dcl changed_process_idx bit (1) init ("0"b); dcl tsptw_mask bit (36) init ("777777000100"b3); dcl tdsdw_mask bit (72) init ("777777777770777777777777"b3); dcl dup_entry (0:63) bit (1) unal; dcl (sdw_regs_ptr, sdw_ptrs_ptr, ptw_regs_ptr, ptw_ptrs_ptr) ptr; dcl (reg_ptr, ptr_ptr, temp_ptr) ptr; dcl (tdsegp, tasdwp, taptwp, sptp, dsegp) ptr; dcl flag_string char (7); dcl usage_string char (8); dcl 1 hard_ptr_space like hardcore_cur; /* Based */ dcl last_three_sets bit (48 * 36) based; dcl 1 sdw_regs (0:63) aligned like amsdwreg based (sdw_regs_ptr); dcl 1 sdw_ptrs (0:63) aligned like amsdwptr based (sdw_ptrs_ptr); dcl 1 ptw_regs (0:63) aligned like amptwreg based (ptw_regs_ptr); dcl 1 ptw_ptrs (0:63) aligned like amptwptr based (ptw_ptrs_ptr); dcl tdsdw bit (72) based (tdsegp); dcl tasdw bit (72) based (tasdwp); dcl tsptw bit (36) based (sptp); dcl taptw bit (36) based (taptwp); /* Static */ /* External */ dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl amu_et_$null_sstp fixed bin(35) ext static; dcl amu_$fdump_mpt_temp_change_idx entry (ptr, fixed bin); dcl amu_$fdump_mpt_revert_idx entry (ptr); dcl amu_$hardcore_info_set_cur_ptrs entry (ptr, ptr); dcl amu_$return_val_idx_from_dbr entry (ptr, fixed bin (24)) returns (fixed bin); dcl amu_$do_translation_hunt_ptr entry (ptr, ptr, ptr, fixed bin (35)); dcl amu_et_$npdx_dbr fixed bin (35) external static; dcl any_other condition; dcl (addr, addrel, baseptr, bin, binary, divide, fixed, null, pointer, ptr, substr) builtin; %page; go to COMMON; azm_verify_dump_ams_$af: entry (P_amu_info_ptr, do_sdws, do_ptws, P_code) returns (bit (1)); af_sw = "1"b; COMMON: on condition (any_other) begin; if changed_process_idx then call amu_$fdump_mpt_revert_idx (amu_info_ptr); changed_process_idx = "0"b; go to done; end; call set_up; if code ^= 0 then go to done; if do_sdws then do; /* verify the SDWAM */ call verify_am_sdw; /* check for duplicate entries */ do idx = 0 to nregs; /* cycle thru ass mem */ if sdw_ptrs (idx).valid then do; /* only for valid entries */ tdsegp = addrel (dsegp, (bin (sdw_ptrs (idx).pointer, 15) * 2)); tasdwp = addr (sdw_regs (idx)); if (tdsdw & tdsdw_mask) ^= tasdw then do; found_mismatch_sdw = "1"b; if af_sw = "0"b then do; call ioa_ ("^/Mis-Match between SDWAM and dseg on Bootload CPU;^/"); call ioa_ (" ADDRESS^2xRINGS^2xBOUND^2xREWPUGC^4xCL F/E USAGE-CT SEG # SEG_NAME"); reg_ptr = addr (sdw_regs (idx)); ptr_ptr = addr (sdw_ptrs (idx)); call display_mismatch_sdw (reg_ptr, ptr_ptr); call display_dseg_entry (tdsegp); end; end; end; end; end; check_ptws: if do_ptws then do; call verify_am_ptw; /* check for duplicate entries */ do idx = 0 to nregs; if ptw_ptrs (idx).valid then do; sdwp = addr (dsegp -> sdwa (bin (ptw_ptrs (idx).pointer, 15))); call get_ptp(sdwp, upt_ptr, sstp, ptp); sptp = addrel (ptp, (divide (binary (ptw_ptrs (idx).pageno, 12), 16, 12, 0))); taptwp = addr (ptw_regs (idx)); if (tsptw & tsptw_mask) ^= taptw then do; /* found a bad one */ found_mismatch_ptw = "1"b; if af_sw = "0"b then do; call ioa_ ("^/Mis-Match between PTWAM and page table on Bootload CPU;^/"); call ioa_ (" ADDRESS^3xM^2xF/E USAGE_CT SEG # PAGE"); reg_ptr = addr (ptw_regs (idx)); ptr_ptr = addr (ptw_ptrs (idx)); call display_mismatch_ptw (reg_ptr, ptr_ptr); call display_sst_entry (sptp); end; end; end; end; end; done: if (found_mismatch_sdw | found_mismatch_ptw | found_dup_entry_sdw | found_dup_entry_ptw) then do; RETURN_VAL = "1"b; go to RET; end; if ^af_sw then call ioa_ ("No mis-matches or duplicate entries found in^[ SDWAM^]^[ or^]^[ PTWAM^].", do_sdws, (do_sdws & do_ptws), do_ptws); RETURN_VAL = "0"b; RET: if changed_process_idx then call amu_$fdump_mpt_revert_idx (amu_info_ptr); P_code = code; if af_sw then return (RETURN_VAL); return; /* logical end */ %page; display_dseg_entry: proc (dseg_entp); dcl dseg_entp ptr; dcl flag_string char (7); dcl 1 dseg_ent based (dseg_entp), ( 2 addr bit (24), 2 ring1 bit (3), 2 ring2 bit (3), 2 ring3 bit (3), 2 pad1 bit (4), 2 bounds bit (14), 2 rd bit (1), 2 ex bit (1), 2 wrt bit (1), 2 priv bit (1), 2 unp bit (1), 2 ebs bit (1), 2 cache bit (1), 2 cl bit (14) ) unal; call ioa_$rsnnl ("^[R^; ^]^[E^; ^]^[W^; ^]^[P^; ^]^[U^; ^]^[G^; ^]^[C^; ^]", flag_string, (0), /* generate the REWPUGC string */ dseg_ent.rd, dseg_ent.ex, dseg_ent.wrt, dseg_ent.priv, dseg_ent.unp, dseg_ent.ebs, dseg_ent.cache); call ioa_ ("^8o^2x^1.3b,^1.3b,^1.3b ^6o^2x^7a ^[^5o^]^-(dseg entry)", binary (dseg_ent.addr, 24), dseg_ent.ring1, dseg_ent.ring2, dseg_ent.ring3, binary ((dseg_ent.bounds || "0000"b), 18), flag_string, ((^dseg_ent.ebs) & dseg_ent.ex), binary (dseg_ent.cl, 14)); return; end display_dseg_entry; %page; display_mismatch_ptw: proc (a_ptw_reg_ptr, a_ptw_ptr_ptr); dcl (a_ptw_reg_ptr, a_ptw_ptr_ptr) ptr; dcl 1 a_ptw_reg aligned like amptwreg based (a_ptw_reg_ptr); dcl 1 a_ptw_ptr aligned like amptwptr based (a_ptw_ptr_ptr); if ^DPS8xxM then call ioa_$rsnnl ("^6x^2d", usage_string, (0), binary (a_ptw_ptr.usage, 4)); else call ioa_$rsnnl ("^2x^6b", usage_string, (0), a_ptw_ptr.usage); call ioa_ ("^8o^2x^[yes^;no ^]^2x^[F^;E^]^2x^8a ^5o ^4o", binary ((a_ptw_reg.addr || "000000"b), 24), a_ptw_reg.modif, a_ptw_ptr.valid, usage_string, binary (a_ptw_ptr.pointer, 15), divide (binary (a_ptw_ptr.pageno, 12), 16, 12, 0)); return; end display_mismatch_ptw; %page; display_mismatch_sdw: proc (a_sdw_reg_ptr, a_sdw_ptr_ptr); dcl (a_sdw_reg_ptr, a_sdw_ptr_ptr) ptr; dcl 1 a_sdw_reg aligned like amsdwreg based (a_sdw_reg_ptr); dcl 1 a_sdw_ptr aligned like amsdwptr based (a_sdw_ptr_ptr); call ioa_$rsnnl ("^[R^; ^]^[E^; ^]^[W^; ^]^[P^; ^]^[U^; ^]^[G^; ^]^[C^; ^]", flag_string, (0), /* generate the REWPUGC string */ a_sdw_reg.read, a_sdw_reg.execute, a_sdw_reg.write, a_sdw_reg.privileged, a_sdw_reg.unpaged, a_sdw_reg.entry_bound_sw, a_sdw_reg.cache); if ^DPS8xxM then call ioa_$rsnnl ("^6x^2d", usage_string, (0), binary (a_sdw_ptr.usage, 4)); else call ioa_$rsnnl ("^2x^6b", usage_string, (0), a_sdw_ptr.usage); call ioa_ ("^8o^2x^1.3b,^1.3b,^1.3b ^6o^2x^7a ^[^5o^;^s^4x-^]^2x^[F^;E^]^2x^8a ^5o", binary (a_sdw_reg.addr, 24), a_sdw_reg.r1, a_sdw_reg.r2, a_sdw_reg.r3, binary ((a_sdw_reg.bound || "0000"b), 18), flag_string, ((^a_sdw_reg.entry_bound_sw) & a_sdw_reg.execute), /* skip next if there is none */ binary (a_sdw_reg.cl, 14), a_sdw_ptr.valid, usage_string, binary (a_sdw_ptr.pointer, 15)); return; end display_mismatch_sdw; %page; display_sst_entry: proc (a_ptp); dcl a_ptp ptr; dcl 1 page_wd based (a_ptp), ( 2 addr bit (18), 2 padd1 bit (11), 2 modifd bit (1), 2 padd2 bit (6) unal ); call ioa_ ("^8o^2x^[yes^;no ^]^2x(page table in memory)", binary ((page_wd.addr || "000000"b), 24), page_wd.modifd); return; end display_sst_entry; %page; get_ptp: proc(sdwp, upt_ptr, sstp, ptp); /* This procedure determines the page table pointer. */ /* parameters */ dcl ptp ptr; dcl sdwp ptr; dcl sstp ptr; dcl upt_ptr ptr; /* automatic */ dcl relative_offset fixed bin(26); dcl sdw_add fixed bin(26); sdw_add = fixed(sdwp->sdw.add,26); if upt_ptr = null() then ptp = ptr (sstp, fixed (sdw.add, 24) - fixed (sst.ptwbase, 18)); else if (sdw_add > upt.upt_absloc & sdw_add < upt.upt_last_loc) then do; /* found in unpaged_page_table */ relative_offset = sdw_add - upt.upt_absloc; ptp = addrel(upt_ptr, relative_offset); end; else if (sdw_add > upt.iupt_absloc & sdw_add < upt.iupt_last_loc) then do; /* found in int_unpaged_page_table */ relative_offset = sdw_add - upt.iupt_absloc; ptp = addrel(upt_ptr, relative_offset); end; else do; /* found in sst_seg */ relative_offset = sdw_add - upt.sst_absloc; ptp = addrel(sstp, relative_offset); end; end get_ptp; %page; set_up: proc; amu_info_ptr = P_amu_info_ptr; P_code, code = 0; process_idx = -1; dumpptr = fdump_info.dump_seg_ptr (0); dump_dbr = fixed (substr (dump.dbr, 1, 24), 24); ptw_regs_ptr = addr (dump.amptwregs); ptw_ptrs_ptr = addr (dump.amptwptrs); sdw_regs_ptr = addr (dump.amsdwregs); sdw_ptrs_ptr = addr (dump.amsdwptrs); process_idx = amu_$return_val_idx_from_dbr (amu_info_ptr, dump_dbr); if process_idx = -1 then do; code = amu_et_$npdx_dbr; /* cant set process index with this dbr */ return; end; call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, process_idx); changed_process_idx = "1"b; /* remember */ hardcore_cur_ptr = addr (hard_ptr_space); /* get pointers to interesting hc */ call amu_$hardcore_info_set_cur_ptrs (amu_info_ptr, hardcore_cur_ptr); sstp = hardcore_cur.sstp; upt_ptr = hardcore_cur.uptp; call amu_$do_translation_hunt_ptr (amu_info_ptr, pointer (baseptr (hardcore_info.dseg), 0), dsegp, code); /* get a pointer to the DSEG */ if code ^= 0 then do; if ^af_sw then call ioa_ ("Cannot get ptr to dseg from dbr ^8o.", dump_dbr); call amu_$fdump_mpt_revert_idx (amu_info_ptr); P_code = code; return; end; temp_ptr = addrel (ptw_regs_ptr, 16); /* base to 2'nd set of regs */ if temp_ptr -> last_three_sets = "0"b then do; /* if second set is zero then */ nregs = 15; /* AMs are from a l68 */ DPS8xxM = "0"b; end; else do; /* No, they are from a DPS8M */ nregs = 63; DPS8xxM = "1"b; end; return; end set_up; %page; verify_am_ptw: proc; if sstp = null () then do; if ^af_sw then call ioa_ ("No sst, cannot verify PTWAM."); call amu_$fdump_mpt_revert_idx (amu_info_ptr); code = amu_et_$null_sstp; return; end; dup_entry (*) = "0"b; do i = 0 to nregs - 1; do j = i + 1 to nregs; if (ptw_ptrs (i).valid & ptw_ptrs (j).valid) then do; if ptw_regs (i).addr = ptw_regs (j).addr then do; dup_entry (i) = "1"b; dup_entry (j) = "1"b; end; else if ptw_ptrs (i).usage = ptw_ptrs (j).usage then do; if ^DPS8xxM then do; /* if its not a dps8 */ dup_entry (i) = "1"b; dup_entry (j) = "1"b; end; end; else if (ptw_ptrs (i).pointer = ptw_ptrs (j).pointer) & (ptw_ptrs (i).pageno = ptw_ptrs (j).pageno) then do; dup_entry (i) = "1"b; dup_entry (j) = "1"b; end; if (dup_entry (i) & dup_entry (j)) then do; if ptw_regs (i).addr = ptw_regs (j).addr then if ptw_ptrs (i).pointer ^= ptw_ptrs (j).pointer then do; if DPS8xxM then go to cancel_dup_ptw; if ptw_ptrs (i).usage ^= ptw_ptrs (j).usage then do; cancel_dup_ptw: dup_entry (i), dup_entry (j) = "0"b; end; end; end; if (dup_entry (i) & dup_entry (j)) then do; found_dup_entry_ptw = "1"b; if af_sw then return; call ioa_ ("^/Possible duplicate entry in PTW associative memory for CPU;^/"); call ioa_ (" ADDRESS^3xM^2xF/E USAGE_CT SEG # PAGE"); reg_ptr = addr (ptw_regs (i)); ptr_ptr = addr (ptw_ptrs (i)); call display_mismatch_ptw (reg_ptr, ptr_ptr); reg_ptr = addr (ptw_regs (j)); ptr_ptr = addr (ptw_ptrs (j)); call display_mismatch_ptw (reg_ptr, ptr_ptr); end; end; end; end; return; end verify_am_ptw; %page; verify_am_sdw: proc; dup_entry (*) = "0"b; found_dup_entry_sdw = "0"b; do i = 0 to nregs - 1; do j = i + 1 to nregs; if (sdw_ptrs (i).valid & sdw_ptrs (j).valid) then do; if sdw_regs (i).addr = sdw_regs (j).addr then do; dup_entry (i) = "1"b; dup_entry (j) = "1"b; end; else if sdw_ptrs (i).pointer = sdw_ptrs (j).pointer then do; dup_entry (i) = "1"b; dup_entry (j) = "1"b; end; else if sdw_ptrs (i).usage = sdw_ptrs (j).usage then do; if ^DPS8xxM then do; /* if its not a dps8 */ dup_entry (i) = "1"b; /* for dps8 it is LRU not usage ctr */ dup_entry (j) = "1"b; end; end; if (dup_entry (i) & dup_entry (j)) then do; if sdw_regs (i).addr = sdw_regs (j).addr then if sdw_regs (i).bound = sdw_regs (j).bound then if (sdw_regs (i).r2 & sdw_regs (i).r3) ^= (sdw_regs (j).r2 & sdw_regs (j).r3) then if sdw_ptrs (i).pointer ^= sdw_ptrs (j).pointer then do; if DPS8xxM then go to cancel_dup_sdw; if sdw_ptrs (i).usage ^= sdw_ptrs (j).usage then do; cancel_dup_sdw: dup_entry (i), dup_entry (j) = "0"b; end; end; end; if (dup_entry (i) & dup_entry (j)) then do; found_dup_entry_sdw = "1"b; if af_sw then return; call ioa_ ("^/Possible duplicate entry in SDW associative memory for CPU;^/"); call ioa_ (" ADDRESS^2xRINGS^2xBOUND^2xREWPUGC^4xCL F/E USAGE-CT SEG # SEG_NAME"); reg_ptr = addr (sdw_regs (i)); ptr_ptr = addr (sdw_ptrs (i)); call display_mismatch_sdw (reg_ptr, ptr_ptr); reg_ptr = addr (sdw_regs (j)); ptr_ptr = addr (sdw_ptrs (j)); call display_mismatch_sdw (reg_ptr, ptr_ptr); end; end; end; end; return; end verify_am_sdw; %page; %include amu_fdump_info; %page; %include amu_hardcore_info; %page; %include amu_info; %page; %include assoc_mem; %page; %include aste; %page; %include bos_dump; %page; %include ptw; %page; %include sdw; %page; %include sst; %page; %include unpaged_page_tables; end azm_verify_dump_ams_;  azm_why_.pl1 08/08/88 1128.5r w 08/08/88 1115.1 282267 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-11-02,Farley), approve(87-07-09,MCR7746), audit(87-07-20,Fawcett), install(87-07-28,MR12.1-1049): Added a check for a valid mc.pr6 prior to calling azm_stack_trace_. 2) change(87-04-14,Parisek), approve(87-07-09,MCR7746), audit(87-07-20,Fawcett), install(87-07-28,MR12.1-1049): Check for valid message in the crash message field. 3) change(87-09-09,Parisek), approve(88-03-09,MCR7861), audit(88-07-08,Farley), install(88-07-12,MR12.2-1055): Change references of BOS to Bootload or BCE. END HISTORY COMMENTS */ azm_why_: proc; return; /*****************************************************************************/ /* */ /* This was originaly written by R. A. Fawcett in the MR9 time frame */ /* rewritten by same for MR11 in Sept of 1984 (but only a small improvment). */ /* entries azm_why_$print_locks, azm_why_$who and azm_why_$mcs */ /* were also added. */ /* Modified Oct 8, 1984 so that mc_area is allocated and then freed. */ /* Modified Jan 21, 1985 by B. Braun to use flagbox.incl.pl1 not */ /* fgbx.incl.pl1.(phx18002) */ /* Modified Jan 21, 1985 by BLB change calling sequence to azm_stack_trace_ */ /* Modified March 1986 by P. Leatherman to print the crash message if present*/ /* */ /*****************************************************************************/ dcl P_sci_ptr ptr; dcl P_amu_info_ptr ptr; dcl P_code fixed bin (35); /* Automatic */ dcl an_entry_found_sw bit (1); dcl bad_guy_known bit (1); dcl bootload_cpu_tag fixed bin (35); dcl bootload_cpu_ptr ptr; dcl could_not_set_lock_sw bit (1); dcl code fixed bin (35); dcl fault_vnum fixed bin; dcl fim_num fixed bin (17); dcl fim_type_fault bit (1); dcl flag_box_area (100) fixed bin (35); dcl inter_code fixed bin (35); dcl 1 hard_ptrs like hardcore_cur; dcl lock_apte_offset fixed bin (18); dcl lock_index fixed bin (17); dcl lock_word (0:6) bit (36); dcl look_for_syserr_sw bit (1); dcl loop_exit bit (1); dcl 1 mc_info (6), 2 ptr ptr, 2 name char (32); dcl mc_info_idx fixed bin; dcl mc_found_frame_sw bit (1); dcl mc_name char (32); dcl no_print_process bit (1); dcl pointer_index fixed bin; dcl prds_num fixed bin; dcl ring_zero_stack bit (1); dcl sci_ptr ptr; dcl 1 scu_inst, 2 address fixed bin unal, 2 pad bit (18) unal; dcl stack_base_segno fixed bin; dcl stack_idx fixed bin; dcl stack_temp_ptrs (0:7) ptr; dcl t_pr_name char (4); dcl temp_indx fixed bin; dcl temp_mcp ptr; dcl temp_name char (32) aligned; dcl temp_num fixed bin; dcl temp_stack_ptr ptr; dcl temp_word bit (36) aligned; dcl trouble_pending fixed bin (35); dcl trouble_pid fixed bin (35); dcl words_requested fixed bin (18); dcl (trouble_ptr, trouble_pid_ptr, lock_ptr, check_entry_ptr, stack_ptr, pds_signal_ptr, pds_pgflt_ptr, pds_fim_ptr, prds_sys_troub_ptr, prds_int_ptr, prds_fim_ptr, real_mcp, temp_ptr) ptr; /* Based */ dcl based_word bit(36) aligned based(temp_ptr); dcl 1 mc_area like mc based (mcp); dcl prs_size (0:7) ptr based; dcl 1 regs_size like mc.regs based; /* Static */ dcl PDS_FIM fixed init (1) static options (constant); dcl PRDS_FIM fixed init (2) static options (constant); dcl PDS_SIG fixed init (3) static options (constant); dcl PRDS_SYS fixed init (4) static options (constant); dcl PDS_PGF fixed init (5) static options (constant); dcl PRDS_INT fixed init (6) static options (constant); dcl cpu_names (0:7) char (1) static options (constant) init ( "a", "b", "c", "d", "e", "f", "g", "h"); dcl lock_seg (0:6) char (32) int static options (constant) init ( "tc_data", "sst_seg", "sst_seg", "scs", "tty_buf", "tty_buf","disk_seg"); dcl lock_symbol (0:6) char (32) int static options (constant) init ( "apt_lock", "ptl", "astl", "connect_lock", "slock", "timer_lock","lock"); dcl disk_seg_lock_index fixed bin int static options (constant) init (6); dcl ptl_lock_index fixed bin (17) int static options (constant) init (1); dcl scu_inst_word fixed bin (18) int static options (constant) init (120); /* Entries */ dcl amu_$definition_offset entry (ptr, char (*), char (*), fixed bin (35)) returns (fixed bin (18)), amu_$definition_set_from entry (ptr, char (*), ptr, fixed bin (35)), amu_$definition_set_prn entry (ptr, char (*), fixed bin, fixed bin (18), fixed bin (35)), amu_$definition_get_prn entry (ptr, char (*), ptr, fixed bin (35)), amu_$do_translation_hunt_ptr entry (ptr, ptr, ptr, fixed bin (35)), amu_$error_for_caller entry () options (variable), amu_$fdump_mpt_current_process entry (ptr), amu_$fdump_mpt_change_idx entry (ptr, fixed bin), amu_$fdump_mpt_revert_idx entry (ptr), amu_$fdump_mpt_temp_change_idx entry (ptr, fixed bin), amu_$return_val_idx_from_dbr entry (ptr, fixed bin (24)) returns (fixed bin), amu_$tc_data_print_this_apte entry (ptr, fixed bin (18), fixed bin (35)); dcl azm_verify_dump_ams_$af entry (ptr, bit (1), bit (1), fixed bin (35)) returns (bit (1)); dcl azm_stack_trace_ entry (char(*), ptr, ptr, ptr, bit (1), bit (1), bit (1), bit (1), fixed bin, fixed bin (35)); dcl azm_stack_trace_$check_for_entry entry (char(*), ptr, ptr, ptr, ptr, fixed bin (35)); dcl azm_stack_trace_$check_for_mc entry (char(*), ptr, ptr, ptr, bit (1), fixed bin (35)); dcl azm_stack_trace_$check_for_syserr entry (char(*), ptr, ptr, ptr, fixed bin (35)); dcl ioa_ entry () options (variable); dcl azm_display_mc_ entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl amu_$definition_ptr entry (ptr, char (*), char (*), fixed bin (35)) returns (ptr); dcl amu_$do_translation entry (ptr, fixed bin, ptr, fixed bin (18), fixed bin (18), fixed bin (35)); dcl amu_$slt_search_seg_num entry (ptr, ptr, char (32) aligned, fixed bin, fixed bin (35)); dcl amu_$hardcore_info_set_cur_ptrs entry (ptr, ptr); dcl ( amu_et_$not_implemented, amu_et_$seg_not_dumped, amu_et_$entry_not_found, amu_et_$no_valid_stacks, error_table_$action_not_performed, error_table_$noentry ) fixed bin (35) ext static; dcl (addr, baseno, baseptr, hbound, lbound, pointer, index, null, fixed, rel, rtrim, size, substr, unspec) builtin; dcl (any_other, cleanup) condition; %page; azm_why_$find_bad_guy: entry (P_sci_ptr, P_amu_info_ptr, P_code); amu_info_ptr = P_amu_info_ptr; sci_ptr = P_sci_ptr; if (amu_info.type ^= FDUMP_TYPE) & (amu_info.type ^= FDUMP_PROCESS_TYPE) then do; P_code = amu_et_$not_implemented; return; end; P_code, code = 0; loop_exit = "0"b; mcp = null(); on cleanup begin; if mcp ^= null() then free mc_area; end; could_not_set_lock_sw, bad_guy_known = "0"b; temp_indx = process_idx; call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, temp_indx); /* remember where */ hardcore_cur_ptr = addr (hard_ptrs); temp_name = "flagbox"; call amu_$hardcore_info_set_cur_ptrs (amu_info_ptr, hardcore_cur_ptr); call amu_$slt_search_seg_num (hardcore_cur.sltp, hardcore_cur.sltntp, temp_name, temp_num, code); if code ^= 0 then do; call ioa_ ("Cannot get flagbox."); goto flagbox_done; end; fgbxp = addr (flag_box_area); words_requested = hbound (flag_box_area, 1); call amu_$do_translation (amu_info_ptr, temp_num, fgbxp, 0, words_requested, code); if code ^= 0 then do; call amu_$fdump_mpt_revert_idx (amu_info_ptr); goto flagbox_done; end; if index (fgbx.message, "") = 0 then call ioa_ ("^/Crash Message:^/^5t^a^/", fgbx.message); flagbox_done: if azm_verify_dump_ams_$af (amu_info_ptr, "1"b, "1"b, code) then do; if code ^= 0 then go to NEXT; call ioa_ ("Inconsistency found in Dump Associative Memories."); bootload_cpu_ptr = amu_$definition_ptr (amu_info_ptr, "scs", "bos_processor_tag", code); if code ^= 0 then do; call amu_$fdump_mpt_revert_idx (amu_info_ptr); P_code = code; return; end; words_requested = 1; call amu_$do_translation (amu_info_ptr, fixed (baseno (bootload_cpu_ptr), 17), addr (bootload_cpu_tag), fixed (rel (bootload_cpu_ptr), 18), words_requested, code); if code ^= 0 then do; call amu_$fdump_mpt_revert_idx (amu_info_ptr); P_code = code; return; end; call ioa_ ("^-Bootload cpu is ^a", cpu_names (bootload_cpu_tag)); end; NEXT: an_entry_found_sw,mc_found_frame_sw = "0"b; temp_name = "fim"; call amu_$slt_search_seg_num (hardcore_cur.sltp, hardcore_cur.sltntp, temp_name, fim_num, code); allocate mc_area set (mcp); scup = addr (mc.scu); code = 0; /* First is the bad guy in scs$trouble_processid ?? */ call who_is_it; if loop_exit then bad_guy_known = "1"b; /* Check for fim_type if valid trouble pending */ trouble_ptr = amu_$definition_ptr (amu_info_ptr, "scs", "sys_trouble_pending", code); if code ^= 0 then do; call amu_$fdump_mpt_revert_idx (amu_info_ptr); P_code = code; goto common_return; end; words_requested = 1; call amu_$do_translation (amu_info_ptr, fixed (baseno (trouble_ptr), 17), addr (trouble_pending), fixed (rel (trouble_ptr), 18), words_requested, code); if code ^= 0 then do; call amu_$fdump_mpt_revert_idx (amu_info_ptr); P_code = code; goto common_return; end; if trouble_pending >= lbound (sys_trouble_reason, 1) & trouble_pending <= hbound (sys_trouble_reason, 1) then do; fim_type_fault = "1"b; call mc_info_init; words_requested = size (mc); call amu_$do_translation (amu_info_ptr, fixed (baseno (pds_fim_ptr), 17), mcp, fixed (rel (pds_fim_ptr), 18), words_requested, code); if bad_guy_known then goto trouble_type (trouble_pending); else do; /* This may be a very early dump */ mc_info_idx = PDS_FIM; real_mcp = mc_info (mc_info_idx).ptr; mc_name = mc_info (mc_info_idx).name; goto call_fim_type; end; end; if ^bad_guy_known then goto could_not_find; goto bad_guy_non_fim; trouble_type (-7): /* Execute fault by operator */ real_mcp = mc_info(PRDS_SYS).ptr; mc_name = mc_info (PRDS_SYS).name; call amu_$do_translation (amu_info_ptr, fixed (baseno (real_mcp), 17), mcp, fixed (rel (real_mcp), 18), 48, code); if code = 0 then do; temp_word = "0"b; arg_bits_ptr = addr (temp_word); arg_bits_def.ppr = "1"b; call azm_display_mc_ (sci_ptr, amu_info_ptr, mcp, arg_bits_ptr, code); end; else call ioa_ ("^a", sys_trouble_reason (trouble_pending)); code = 0; call list_locks ("1"b); call check_mcs; goto common_return; trouble_type (-4): /* "Fault/Interrupt with PLT set" */ call print_the_lock (ptl_lock_index); pointer_index = 2; goto common_other; trouble_type (-1): /* "Page fault while on prds" */ /* page_fault uses the ap pointer to look at machine conditions */ pointer_index = 0; goto common_other; trouble_type (-2): trouble_type (-3): trouble_type (-5): trouble_type (-6): trouble_type (-8): trouble_type (-9): trouble_type (-10): trouble_type (-11): /* just incase others are added */ trouble_type (-12): trouble_type (-13): trouble_type (-14): trouble_type (-15): /* All others */ pointer_index = 2; common_other: temp_name = "fault_vector"; call amu_$slt_search_seg_num (hardcore_cur.sltp, hardcore_cur.sltntp, temp_name, fault_vnum, code); if code ^= 0 then do; P_code = code; goto could_not_find; end; temp_ptr = addr (scu_inst); words_requested = 1; call amu_$do_translation (amu_info_ptr, fault_vnum, temp_ptr, scu_inst_word, words_requested, code); if code ^= 0 then do; P_code = code; goto could_not_find; end; temp_num = scu_inst.address; words_requested = size (scu_inst) + 1; call amu_$do_translation (amu_info_ptr, fault_vnum, addr (temp_ptr), (temp_num), words_requested, code); if code ^= 0 then do; P_code = code; goto could_not_find; end; temp_mcp = pointer (temp_ptr,0); temp_num = size(prs_size) + size(regs_size); temp_num = fixed (rel (temp_ptr), 17) - temp_num; temp_num = temp_num + (pointer_index * 2); words_requested = 2; call amu_$do_translation (amu_info_ptr, fixed (baseno (temp_ptr), 17), addr (temp_mcp), (temp_num), words_requested, code); if code ^= 0 then goto could_not_find; do mc_info_idx = 1 to 6; if mc_info (mc_info_idx).ptr = temp_mcp then do; real_mcp = mc_info (mc_info_idx).ptr; mc_name = mc_info (mc_info_idx).name; goto call_fim_type; end; end; could_not_find: /* could not find the bad guy */ call amu_$fdump_mpt_revert_idx (amu_info_ptr); call ioa_ ("Could not find the failing process."); if fgbx.bce_entry ^= 0 then call ioa_ ("Manual return to BCE ?"); if ^could_not_set_lock_sw then call list_locks ("1"b); common_return: if P_code = error_table_$action_not_performed then P_code = 0; if ^(an_entry_found_sw | mc_found_frame_sw) then P_code = error_table_$action_not_performed; if ^no_print_process then call amu_$fdump_mpt_current_process (amu_info_ptr); if mcp ^= null() then free mc_area; return; call_fim_type: call ioa_ ("^a", sys_trouble_reason (trouble_pending)); words_requested = size (mc); call amu_$do_translation (amu_info_ptr, fixed (baseno (real_mcp), 17), mcp, fixed (rel (real_mcp), 18), words_requested, code); if code ^= 0 then goto could_not_find; if ^bad_guy_known then do; do mc_info_idx = 1 to 6 while (^mc_found_frame_sw); if unspec (scu) = "0"b then do; real_mcp = mc_info (mc_info_idx).ptr; mc_name = mc_info (mc_info_idx).name; call amu_$do_translation (amu_info_ptr, fixed (baseno (real_mcp), 17), mcp, fixed (rel (real_mcp), 18), 48,code); end; else do; mc_found_frame_sw = "1"b; call ioa_ ("Will use machine conditions at ^a",mc_name); end; end; end; else do; if trouble_pending = trbl_prds_pf then do; if scu.fi_num ^= "10001"b | scu.fi_flag ^= "1"b then goto bad_guy_non_fim; if fixed (baseno (mc.prs (6)), 17) ^= hardcore_info.prds then goto bad_guy_non_fim; end; mc_found_frame_sw = "1"b; end; if ^mc_found_frame_sw then goto exit_via_fim; call mc_fim_type (bad_guy_known); if code ^= 0 then goto exit_via_fim; temp_ptr = amu_$definition_ptr (amu_info_ptr, "active_all_rings_data", "stack_base_segno", code); if code ^= 0 then do; if bad_guy_known then goto exit_via_fim; else do; on any_other begin; code = error_table_$action_not_performed; goto bad_data; end; if addr(mc.prs(6)) -> its.its_mod = ITS_MODIFIER then if addr(mc.prs(6)) -> its.mod = "0"b then if mc.prs(6) ^= null () then do; call azm_stack_trace_ ("why", sci_ptr, amu_info_ptr, pointer (mc.prs(6),0), "0"b, "0"b, "0"b, "1"b, 0, code); if code = amu_et_$no_valid_stacks then code = 0; end; bad_data: revert any_other; goto bad_guy_non_fim; end; end; on any_other begin; code = error_table_$action_not_performed; goto bad_stack_data; end; if addr(mc.prs(6)) -> its.its_mod = ITS_MODIFIER then if addr(mc.prs(6)) -> its.mod = "0"b then if mc.prs(6) ^= null () then do; call azm_stack_trace_ ("why", sci_ptr, amu_info_ptr, pointer(mc.prs(6),0), "0"b, "0"b, "0"b, "1"b, 0, code); if code = amu_et_$no_valid_stacks then code = 0; end; exit_via_fim: P_code = code; goto common_return; bad_guy_non_fim: on any_other begin; code = error_table_$action_not_performed; goto bad_stack_data; end; call non_fim_type; bad_stack_data: revert any_other; P_code = code; goto common_return; /* end find the bad_guy */ %page; azm_why_$print_locks: entry (P_sci_ptr, P_amu_info_ptr, P_lock_symb, P_set, P_code); dcl P_lock_symb char (*); dcl P_set bit (1); amu_info_ptr = P_amu_info_ptr; sci_ptr = P_sci_ptr; if (amu_info.type ^= FDUMP_TYPE) & (amu_info.type ^= FDUMP_PROCESS_TYPE) then do; P_code = amu_et_$not_implemented; return; end; P_code, code = 0; could_not_set_lock_sw, bad_guy_known = "0"b; hardcore_cur_ptr = addr (hard_ptrs); call amu_$hardcore_info_set_cur_ptrs (amu_info_ptr, hardcore_cur_ptr); if P_lock_symb = "" then call list_locks (P_set); else do lock_index = 0 to hbound (lock_symbol, 1); if P_lock_symb = lock_symbol (lock_index) then do; call print_the_lock (lock_index); if P_set then call set_to_lock; end; end; lock_exit: P_code = code; return; %page; azm_why_$who: entry (P_sci_ptr, P_amu_info_ptr, P_code); amu_info_ptr = P_amu_info_ptr; sci_ptr = P_sci_ptr; if (amu_info.type ^= FDUMP_TYPE) & (amu_info.type ^= FDUMP_PROCESS_TYPE) then do; P_code = amu_et_$not_implemented; return; end; P_code, code = 0; hardcore_cur_ptr = addr (hard_ptrs); call amu_$hardcore_info_set_cur_ptrs (amu_info_ptr, hardcore_cur_ptr); call who_is_it; if loop_exit = "0"b then P_code = error_table_$action_not_performed; else P_code = 0; return; azm_why_$mcs: entry (P_sci_ptr, P_amu_info_ptr, P_code); amu_info_ptr = P_amu_info_ptr; sci_ptr = P_sci_ptr; if (amu_info.type ^= FDUMP_TYPE) & (amu_info.type ^= FDUMP_PROCESS_TYPE) then do; P_code = amu_et_$not_implemented; return; end; P_code, code = 0; mc_found_frame_sw = "0"b; call check_mcs; if mc_found_frame_sw then P_code = 0; else P_code = code; return; %page; mc_info_init: proc; pds_fim_ptr = amu_$definition_ptr (amu_info_ptr, "pds", "fim_data", code); if code ^= 0 then goto could_not_find; mc_info (PDS_FIM).ptr = pds_fim_ptr; mc_info (PDS_FIM).name = "pds$fim_data"; pds_pgflt_ptr = amu_$definition_ptr (amu_info_ptr, "pds", "page_fault_data", code); mc_info (PDS_PGF).ptr = pds_pgflt_ptr; mc_info (PDS_PGF).name = "pds$page_fault_data"; pds_signal_ptr = amu_$definition_ptr (amu_info_ptr, "pds", "signal_data", code); mc_info (PDS_SIG).ptr = pds_signal_ptr; mc_info (PDS_SIG).name = "pds$signal_data"; prds_fim_ptr = amu_$definition_ptr (amu_info_ptr, "prds", "fim_data", code); mc_info (PRDS_FIM).ptr = prds_fim_ptr; mc_info (PRDS_FIM).name = "prds$fim_data"; prds_num = fixed (baseno (mc_info (PRDS_FIM).ptr), 17); prds_int_ptr = amu_$definition_ptr (amu_info_ptr, "prds", "interrupt_data", code); mc_info (PRDS_INT).ptr = prds_int_ptr; mc_info (PRDS_INT).name = "prds$interrupt_data"; prds_sys_troub_ptr = amu_$definition_ptr (amu_info_ptr, "prds", "sys_trouble_data", code); mc_info (PRDS_SYS).ptr = prds_sys_troub_ptr; mc_info (PRDS_SYS).name = "prds$sys_trouble_data"; end mc_info_init; %page; non_fim_type: proc; /* Now we must search the stacks (those that can be used by hardcore) for call_bce and syserr_real */ /* First look for syserr_real */ an_entry_found_sw = "0"b; look_for_syserr_sw = "1"b; call check_stacks; look_for_syserr_sw = "0"b; if code ^= 0 then do; if (code ^= amu_et_$entry_not_found) & (code ^= amu_et_$no_valid_stacks) & (code ^= error_table_$noentry) then call amu_$error_for_caller (amu_info_ptr, code, "why", "looking for syserr"); /* no call to syserr then look for call_bce */ check_entry_ptr = amu_$definition_ptr (amu_info_ptr, "call_bce", "call_bce", code); if code ^= 0 then do; call amu_$error_for_caller (amu_info_ptr, code, "why", "looking for call_bce$call_bce"); code = 0; goto call_check_mcs; end; call check_stacks; if code = 0 then an_entry_found_sw = "1"b; else code = 0; end; else an_entry_found_sw = "1"b; call_check_mcs: call check_mcs; if code = error_table_$action_not_performed then code = 0; end non_fim_type; %page; check_mcs: proc; code = 0; if idle_process () then do; return; /* idle processes don't have a stack */ end; temp_ptr = amu_$definition_ptr (amu_info_ptr, "pds", "stacks", code); if code ^= 0 then do; return; end; words_requested = size (stack_temp_ptrs (*)); call amu_$do_translation (amu_info_ptr, fixed (baseno (temp_ptr), 17), addr (stack_temp_ptrs), fixed (rel (temp_ptr), 18), words_requested, code); if code ^= 0 then do; return; end; do stack_idx = 7 by -1 to 0; if stack_idx = 0 then ring_zero_stack = "1"b; else ring_zero_stack = "0"b; if stack_temp_ptrs (stack_idx) ^= null then do; call azm_stack_trace_$check_for_mc ("why", sci_ptr, amu_info_ptr, stack_temp_ptrs (stack_idx), ring_zero_stack, code); if code ^= 0 then do; if (code ^= amu_et_$no_valid_stacks) & (code ^= amu_et_$seg_not_dumped) & (code ^= error_table_$action_not_performed) then call amu_$error_for_caller (amu_info_ptr, code, "why", "stack ^p", stack_temp_ptrs (stack_idx)); if code = amu_et_$no_valid_stacks then code = 0; end; else mc_found_frame_sw = "1"b; end; end; end check_mcs; %page; check_stacks: proc; /* Try prds */ stack_ptr = baseptr (substr (unspec (hardcore_info.prds), 19)); if look_for_syserr_sw then call azm_stack_trace_$check_for_syserr ("why", sci_ptr, amu_info_ptr, stack_ptr, code); else call azm_stack_trace_$check_for_entry ("why", sci_ptr, amu_info_ptr, stack_ptr, check_entry_ptr, code); if code = 0 then do; an_entry_found_sw = "1"b; return; end; if code = amu_et_$no_valid_stacks then code = 0; /* setup for stack_0 */ temp_ptr = amu_$definition_ptr (amu_info_ptr, "active_all_rings_data", "stack_base_segno", code); if code ^= 0 then return; words_requested = 1; call amu_$do_translation (amu_info_ptr, fixed (baseno (temp_ptr), 17), addr (stack_base_segno), fixed (rel (temp_ptr), 18), words_requested, code); if code ^= 0 then return; /* first check stack_0 */ stack_ptr = baseptr (substr (unspec (stack_base_segno), 19)); if look_for_syserr_sw then call azm_stack_trace_$check_for_syserr ("why", sci_ptr, amu_info_ptr, stack_ptr, code); else call azm_stack_trace_$check_for_entry ("why", sci_ptr, amu_info_ptr, stack_ptr, check_entry_ptr, code); if code ^= 0 then do; if code = amu_et_$seg_not_dumped then do; /* stack_0 not in dump try inzr_stk0 */ code = 0; temp_name = "inzr_stk0"; call amu_$slt_search_seg_num (hardcore_cur.sltp, hardcore_cur.sltntp, temp_name, stack_base_segno, code); if code ^= 0 then return; stack_ptr = baseptr (substr (unspec (stack_base_segno), 19)); if look_for_syserr_sw then call azm_stack_trace_$check_for_syserr ("why", sci_ptr, amu_info_ptr, stack_ptr, code); else call azm_stack_trace_$check_for_entry ("why", sci_ptr, amu_info_ptr, stack_ptr, check_entry_ptr, code); if code = 0 then an_entry_found_sw = "1"b; end; end; if code = 0 then an_entry_found_sw = "1"b; end check_stacks; %page; idle_process: proc () returns (bit (1)); dcl based_char char (32) based (t_ptr); dcl code fixed bin (35); dcl idle_sw bit (1); dcl t_data (8) fixed bin (35); dcl t_idx fixed bin; dcl t_offset fixed bin (18); dcl t_ptr ptr; dcl t_segno fixed bin; if amu_info.process_info_ptr -> process_info.apte.foreign_ptr = null () then aptep = amu_info.process_info_ptr -> process_info.apte.local_ptr; else aptep = amu_info.process_info_ptr -> process_info.apte.foreign_ptr; if aptep = null () then return ("0"b); code = 0; idle_sw = "0"b; call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, amu_info.process_idx); /* this way revert will always work */ t_idx = amu_$return_val_idx_from_dbr (amu_info_ptr, fixed (substr (unspec (apte.dbr), 1, 24), 24)); if t_idx = -1 then goto END_IDLE; /* process is not in dump so assume its not idle */ call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, t_idx); t_ptr = addr (t_data); t_segno = hardcore_info.segno.pds; t_offset = amu_$definition_offset (amu_info_ptr, "pds", "process_group_id", code); if code ^= 0 then goto END_IDLE; words_requested = size (t_data); call amu_$do_translation (amu_info_ptr, t_segno, t_ptr, t_offset, words_requested, code); if code ^= 0 then goto END_IDLE; /* can't get id, assume its not idle */ if index (based_char, "Idle") ^= 0 then idle_sw = "1"b; END_IDLE: call amu_$fdump_mpt_revert_idx (amu_info_ptr); return (idle_sw); end idle_process; %page; mc_fim_type: proc (set_it); dcl set_it bit (1); temp_word = "0"b; arg_bits_ptr = addr (temp_word); arg_bits_def.ppr, arg_bits_def.tpr = "1"b; arg_bits_def.set_ptr = set_it; call azm_display_mc_ (sci_ptr, amu_info_ptr, mcp, arg_bits_ptr, code); if code = 0 & set_it then do; t_pr_name = "prmc"; call amu_$definition_set_prn (amu_info_ptr, t_pr_name, fixed (baseno (real_mcp), 17), fixed (rel (real_mcp), 18), code); t_pr_name = "prs"; call amu_$definition_set_from (amu_info_ptr, t_pr_name, mcp, code); t_pr_name = "pr6"; call amu_$definition_get_prn (amu_info_ptr, t_pr_name, temp_ptr, code); temp_stack_ptr = temp_ptr; t_pr_name = "prfr"; call amu_$definition_set_prn (amu_info_ptr, t_pr_name, fixed (baseno (temp_ptr), 17), fixed (rel (temp_ptr), 18), code); end; end mc_fim_type; %page; list_locks: proc (set_for_lock); dcl set_for_lock bit (1); lock_word (*) = "0"b; do lock_index = 0 to hbound (lock_word, 1); call print_the_lock (lock_index); end; if ^set_for_lock then return; /* start at 1 because the tc_data lock does not contain a process_id */ do lock_index = 1 to hbound (lock_word, 1); if lock_word (lock_index) ^= "0"b then do; call set_to_lock; return; end; end; could_not_set_lock_sw = "1"b; end list_locks; %page; set_to_lock: proc; if lock_word(lock_index) = "0"b then do; could_not_set_lock_sw = "1"b; return; end; if process_info.pid = lock_word (lock_index) then do; /* this is easy */ no_print_process = "1"b; call ioa_ ("^a$^a locked by current process", lock_seg (lock_index), lock_symbol (lock_index)); loop_exit = "1"b; return; end; do temp_indx = 0 to hbound (fdump_process_table.array, 1); if fdump_process_table.array (temp_indx).apte_offset = fixed (substr (unspec (lock_word (lock_index)), 1, 18), 18) then do; /* Looks like this is the guy so setup the proc hold for it */ call amu_$fdump_mpt_change_idx (amu_info_ptr, temp_indx); call ioa_ ("Setting process for ^a$^a", lock_seg (lock_index), lock_symbol (lock_index)); call amu_$fdump_mpt_temp_change_idx (amu_info_ptr, temp_indx); no_print_process = "0"b; return; end; end; call ioa_ ("Could not find process holding lock."); could_not_set_lock_sw = "1"b; end set_to_lock; %page; print_the_lock: proc (index); dcl seg_symb char (32); dcl offset_symb char (32); dcl index fixed bin; dcl lock_name char (32); dcl 1 dim_check aligned, 2 pad bit (18) unal, 2 mbz bit (18) unal; seg_symb = lock_seg (index); offset_symb = lock_symbol (index); lock_name = rtrim (seg_symb) || "$" || rtrim (offset_symb); lock_apte_offset = 0; if index = disk_seg_lock_index then do; temp_name = "disk_seg"; call amu_$slt_search_seg_num (hardcore_cur.sltp, hardcore_cur.sltntp, temp_name, temp_num, code); words_requested = 1; call amu_$do_translation (amu_info_ptr,temp_num,addr(dim_check), fixed(rel(addr(baseptr(temp_num) -> disk_data.array(1))),18), words_requested,code); if dim_check.mbz ^= "0"b then do; call ioa_ ("^5x^32a not found", lock_name); lock_word(index) = "0"b; return; end; lock_ptr = pointer(baseptr(temp_num), fixed(rel(addr(baseptr(temp_num) -> disk_data.lock)),17)); end; else lock_ptr = amu_$definition_ptr (amu_info_ptr, seg_symb, offset_symb, inter_code); temp_ptr = null (); call amu_$do_translation_hunt_ptr (amu_info_ptr, lock_ptr, temp_ptr, code); if temp_ptr = null then do; lock_word (index) = "0"b; if ^bad_guy_known then do; call ioa_ ("^5x^32a not found", lock_name); return; end; if inter_code ^= 0 then do; call amu_$error_for_caller (amu_info_ptr, inter_code, "why", "Resolving ^a$^a", rtrim (seg_symb),rtrim (offset_symb)); code = inter_code; return; end; call amu_$error_for_caller (amu_info_ptr, 0, "why", "Cannot find ^a$^a", rtrim (seg_symb),rtrim (offset_symb)); return; end; lock_word (index) = based_word; lock_apte_offset = fixed (substr (unspec (based_word), 1, 18), 18); if index = 0 then do; call ioa_ ("^5x^32a ^w", lock_name, based_word); return; end; if based_word ^= "0"b & substr (based_word, 1, 3) ^= "7"b3 then do; call ioa_ ("^5x^32a locked by:", lock_name); call amu_$tc_data_print_this_apte (amu_info_ptr, lock_apte_offset, code); if code ^= 0 then return; call ioa_ (" "); end; else call ioa_ ("^5x^32a ^[unlocked^;^w^]", lock_name, (based_word = "0"b), based_word); end print_the_lock; %page; who_is_it: proc; loop_exit = "0"b; no_print_process = "0"b; trouble_pid_ptr = amu_$definition_ptr (amu_info_ptr, "scs", "trouble_processid", code); if trouble_pid_ptr ^= null () then do; /* we may know the bad guy */ words_requested = 1; call amu_$do_translation (amu_info_ptr, fixed (baseno (trouble_pid_ptr), 17), addr (trouble_pid), fixed (rel (trouble_pid_ptr), 18), words_requested, code); if code ^= 0 then do; call amu_$fdump_mpt_revert_idx (amu_info_ptr); P_code = code; return; end; /* looks better and better */ if trouble_pid ^= 0 then do; /* This should be it */ if process_info.pid = unspec (trouble_pid) then do; /* this is easy */ no_print_process = "1"b; loop_exit = "1"b; return; end; do temp_indx = 0 to hbound (fdump_process_table.array, 1); if fdump_process_table.array (temp_indx).apte_offset = fixed (substr (unspec (trouble_pid), 1, 18), 18) then do; call amu_$fdump_mpt_change_idx (amu_info_ptr, temp_indx); loop_exit = "1"b; end; end; end; end; end who_is_it; %page; %include dskdcl; %page; %include mc; %page; %include amu_mc; %page; %include amu_info; %page; %include amu_process_info; %page; %include amu_fdump_info; %page; %include amu_hardcore_info; %page; %include flagbox; %page; %include sys_trouble_codes; %page; %include apte; %page; %include its; end azm_why_;  copy_deadproc.pl1 07/12/88 1443.5rew 07/12/88 1432.9 200007 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ copy_deadproc: proc(); /* format: off */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This is a tool to copy dead processes from the >pdd to >dumps>save_pdirs */ /* directory. */ /* */ /* Status: */ /* */ /* 0) Created: June 1984 by B. Braun */ /* 1) Modified: 06 Dec 84 by B. Braun to not set system_privileges when */ /* getting the access class of the source dir */ /* fails. Print better error message when */ /* deleting the source dir fails. */ /* 2) Modified: 23 Jan 85 by B. Braun to set the 256K switch. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /****^ HISTORY COMMENTS: 1) change(87-07-09,Parisek), approve(87-07-09,MCR7746), audit(87-07-16,Fawcett), install(87-07-28,MR12.1-1049): Add the no_copy_delete control functionality. 2) change(87-07-18,GDixon), approve(88-03-09,MCR7861), audit(88-07-08,Farley), install(88-07-12,MR12.2-1055): A) Add copy_liveproc command. B) Correct problem in cleanup. 3) change(87-10-26,GDixon), approve(88-03-09,MCR7861), audit(88-07-08,Farley), install(88-07-12,MR12.2-1055): A) Fix bug in determine_hphcs_need internal subroutine. END HISTORY COMMENTS */ %page; /* External entries */ dcl aim_check_$equal entry (bit(72) aligned, bit(72) aligned) returns(bit(1) aligned); dcl check_gate_access_ entry (char(*), ptr, fixed bin(35)); dcl com_err_ entry() options(variable); dcl command_query_$yes_no entry() options(variable); dcl copy_pdir_$deadproc entry (char(*), char(*), char(*), char(*), char(*), char(*), bit(1), fixed bin(35)); dcl copy_pdir_$delete entry (char(*), char(*), char(*), fixed bin(35)); dcl copy_pdir_$liveproc entry (char(*), char(*), char(*), char(*), char(*), char(*), bit(1), char(*), fixed bin(35)); dcl cu_$arg_count entry (fixed bin, fixed bin(35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35)); dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); dcl get_authorization_ entry returns (bit (72)); dcl get_privileges_ entry() returns(bit(36) aligned); dcl hcs_$get_access_class entry (char(*), char(*), bit(72) aligned, fixed bin(35)); dcl hcs_$get_user_effmode entry (char(*), char(*), char(*), fixed bin, fixed bin(5), fixed bin(35)); dcl hcs_$set_256K_switch entry (bit(2) aligned, bit(2) aligned, fixed bin(35)); dcl hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35)); dcl pathname_ entry (char(*), char(*)) returns(char(168)); dcl system_privilege_$dir_priv_off entry (fixed bin(35)); dcl system_privilege_$dir_priv_on entry (fixed bin(35)); dcl system_privilege_$seg_priv_off entry (fixed bin(35)); dcl system_privilege_$seg_priv_on entry (fixed bin(35)); dcl upd_free_name_$retain_suffix entry (char(*), char(*), char(*), fixed bin(35)); dcl upd_free_name_$restore_with_suffix entry (char(*), char(*), char(*), fixed bin(35)); dcl ( error_table_$action_not_performed, error_table_$badopt, error_table_$incorrect_access, error_table_$moderr, error_table_$no_m_permission, error_table_$no_s_permission, error_table_$noarg, error_table_$noentry, error_table_$notadir ) fixed bin(35) ext static; /* options constant variables */ dcl ( DEFAULT_DIR char(5) init(">pdd>"), DIR_TYPE fixed bin(2) init(2), FALSE bit (1) init ("0"b), PDIR_PATH char(17) init(">dumps>save_pdirs"), PDIR_SUFFIX char(4) init ("pdir"), TRUE bit (1) init ("1"b) ) int static options(constant); %page; /* Builtins */ dcl (addr, before, index, null, rtrim, search, substr) builtin; /* Condition handlers */ dcl cleanup condition; /* Based variables */ dcl arg char (al) based (ap); dcl dir_str char(dir_len) based(dir_ptr); dcl name_str char(name_len) based(name_ptr); dcl 1 privileges like aim_privileges based (addr(priv_string)); /* Automatic */ dcl al fixed bin(21); dcl ap ptr; dcl argno fixed bin; dcl caller_access_class bit(72) aligned; dcl code fixed bin (35); dcl delete_sw bit(1); dcl deadproc bit(1); dcl dir_len fixed bin(21); dcl dir_ptr ptr; dcl dirname char(168); dcl ename char(32); dcl ignore fixed bin(24); dcl ignore_code fixed bin(35); dcl mode fixed bin(5); dcl myname char(13); dcl name_sw bit(1); dcl nargs fixed bin; dcl name_len fixed bin(21); dcl name_ptr ptr; dcl ncd_sw bit(1); dcl need_hphcs bit(1); dcl need_priv bit(1); dcl no_chase fixed bin(1); dcl old_256k_sw bit(2) aligned; dcl owner_sw bit(1); dcl parent_access bit(1); dcl parent_access_class bit (72) aligned; dcl person_proj char(32); dcl pdir_access_class bit (72) aligned; dcl pdir_path char(168); dcl pdir_to_create char(32); dcl priv_string bit(36) aligned; dcl privileges_are_set bit(1); dcl restore_names bit(1); dcl target_dir char(168); dcl target_dirname char(168); dcl target_parent char(168); dcl tdirname char(168); dcl tename char(32); dcl type fixed bin(2); dcl yes_sw bit(1); %page; deadproc = TRUE; myname = "copy_deadproc"; go to COMMON; copy_liveproc: entry; deadproc = FALSE; myname = "copy_liveproc"; go to COMMON; COMMON: delete_sw, name_sw, ncd_sw, old_256k_sw, owner_sw, need_hphcs, need_priv, restore_names, parent_access, privileges_are_set = FALSE; target_dir = PDIR_PATH; name_ptr, dir_ptr = null(); code = 0; no_chase = 0; on cleanup begin; call clean_up(); end; call cu_$arg_count(nargs, code); if code ^= 0 then do; call com_err_(code,myname); goto EXIT; end; if nargs = 0 then if deadproc then call argument_error (error_table_$noarg, "^/A process directory name must be provided.^/^a", "Usage: copy_deadproc {deadproc_name} {-ctl_args}", ""); else call argument_error (error_table_$noarg, "^/A process directory name and user name must be provided.^/^a", "Usage: copy_liveproc {live_pdir_name} {user_name} {-ctl_args}", ""); %page; do argno = 1 to nargs; /* process args */ call cu_$arg_ptr(argno, ap, al, (0)); if deadproc & (arg = "-delete" | arg = "-dl") then delete_sw = TRUE; else if deadproc & (arg = "-no_delete" | arg = "-ndl") then delete_sw = FALSE; else if deadproc & (arg = "-no_copy_delete" | arg = "-ncd") then ncd_sw = TRUE; else if arg = "-owner" | arg = "-ow" then owner_sw = TRUE; else if ^deadproc & (arg = "-directory" | arg = "-dir" | arg = "-dr") then do; if dir_ptr ^= null then call argument_error (0, "More than one directory was specified. ^a, ^a", dir_str, arg); call get_next_arg ("directory name", dir_ptr, dir_len); end; else if arg = "-name" | arg = "-nm" then do; if name_ptr ^= null() then call argument_error (0, "More than one name is specified. ^a, ^a", name_str, arg); if deadproc then call get_next_arg ("deadproc name", name_ptr, name_len); else call get_next_arg ("user name", name_ptr, name_len); end; else if substr(arg, 1, 1) ^= "-" then do; /* assume either */ if ^deadproc & dir_ptr = null then do; /* pdir pathname */ dir_len = al; dir_ptr = ap; end; else if name_ptr = null() then do; /* or deadproc */ name_len = al; /* or user name */ name_ptr = ap; end; else call argument_error (0, "More than one name is specified. ^a, ^a", name_str, arg); end; else call argument_error(error_table_$badopt, " ^a",arg, ""); end; /* end args loop */ if deadproc then do; if name_ptr = null() then call argument_error(error_table_$noarg, "A deadproc name must be specified.", "", ""); if search(name_str, "<>") = 0 then pdir_path = DEFAULT_DIR || name_str; /* process_dir_dir is the default */ else pdir_path = name_str; end; else do; if dir_ptr = null() then call argument_error(error_table_$noarg, "A liveproc directory name must be specified.", "", ""); if name_ptr = null() then call argument_error(error_table_$noarg, "A user name must be specified.", "", ""); if search(dir_str, "<>") = 0 then pdir_path = DEFAULT_DIR || dir_str; /* process_dir_dir is the default */ else pdir_path = dir_str; end; %page; /* need access to phcs_ */ call check_gate_access_ ("phcs_", null(), code); if code ^= 0 then do; if code = error_table_$noentry then call report_error(code, "Checking access to the phcs_ gate.", "", ""); else if code = error_table_$moderr then call report_error(code, "Execute access is required on the phcs_ gate.", "", ""); end; /* does the pdir specified exist? */ call expand_pathname_ (pdir_path, dirname, ename, code); if code ^= 0 then call report_error(code, "^a", pathname_(dirname, ename), ""); /* get access class of source pdir */ call hcs_$get_access_class (dirname, ename, pdir_access_class, code); if code ^= 0 then call report_error(code, "^a", pathname_(dirname, ename), ""); caller_access_class = get_authorization_ (); /* get the access_class of the process */ if aim_check_$equal (caller_access_class, pdir_access_class) then; /* dont need privileges */ else do; /* need privileges */ if ^(privileges_are_set) then call set_privileges(code); if code ^= 0 then do; if code = error_table_$noentry then call report_error(code, "Checking access to the system_privilege_ gate.", "", ""); else if code = error_table_$moderr then call report_error(code, "Execute access is required on the system_privilege_ gate.", "", ""); else call report_error(code, "^a", pathname_(dirname, ename), ""); end; parent_access = TRUE; end; /* If -owner is specified, then the pdir can only be copied if the access class of the */ /* source pdir is equal to the target parent dir. */ if owner_sw then do; call expand_pathname_ (target_dir, target_dirname, target_parent, code); if code ^= 0 then call report_error(code, "^a", pathname_(target_dirname, target_parent), ""); /* get access class of parent of target dir */ call hcs_$get_access_class (target_dirname, target_parent, parent_access_class, code); if code ^= 0 then call report_error(code, "^a", pathname_(target_dirname, target_parent), ""); if pdir_access_class ^= parent_access_class then call report_error (error_table_$action_not_performed, "^/When -owner is used, the access class of pdir ^a must equal the access class of the target directory ^a.", pathname_(dirname, ename), pathname_(target_dirname, target_parent)); end; call hcs_$status_minf (dirname, ename, no_chase, type, ignore, code); if code ^= 0 then call report_error(code, "^a", pathname_(dirname, ename), ""); if type ^= DIR_TYPE then call report_error(error_table_$notadir, "^a", pathname_(dirname, ename), ""); /* determine access of the pdir to be copied */ call hcs_$get_user_effmode (dirname, ename, "", -1, mode, code); if code ^= 0 then call report_error(code, "^a", pathname_(dirname, ename), ""); if mode ^= SMA_ACCESS_BIN & mode ^= SM_ACCESS_BIN then call report_error(error_table_$moderr, "SM access is required on ^a", pathname_(dirname, ename), ""); %page; if delete_sw | ncd_sw then do; /* to delete user needs SM on containing dir */ call expand_pathname_ (dirname, tdirname, tename, code); if code ^= 0 then call report_error(code, "^a", dirname, ""); call hcs_$get_user_effmode (tdirname, tename, "", -1, mode, code); if code ^= 0 then call report_error(code, "^a", dirname, ""); if mode ^= SMA_ACCESS_BIN & mode ^= SM_ACCESS_BIN then do; /* query the user to continue */ if mode = S_ACCESS_BIN then code = error_table_$no_m_permission; else if mode = M_ACCESS_BIN then code = error_table_$no_s_permission; else code = error_table_$incorrect_access; if ncd_sw then call report_error (error_table_$incorrect_access, "Modify access is needed on containing dir ^a to delete ^a.", dirname, pathname_(dirname, ename)); if delete_sw then call command_query_$yes_no (yes_sw, code, myname, "In order to delete the pdir ^a, Modify access is needed on the containing dir ^a. If you continue, the pdir will be copied but not deleted.", "The directory ^a can be copied but not deleted. Do you wish to continue?", pathname_(dirname, ename), dirname); if ^(yes_sw) then call report_error(error_table_$action_not_performed, "Copying ^a.", ename, ""); delete_sw = FALSE; /* continue and */ end; /* dont delete */ end; if deadproc /* get target dir*/ then call construct_names_from_pdir (ename, pdir_to_create, person_proj); else do; pdir_to_create = rtrim(name_str) || "." || PDIR_SUFFIX; person_proj = name_str; end; if ^ncd_sw then do; need_hphcs = determine_hphcs_need(dirname, ename, person_proj); if need_hphcs then do; /* To copy the user needs "re" to hphcs_ gate. */ call check_gate_access_ ("hphcs_", null(), code); if code ^= 0 then do; if code = error_table_$noentry then call report_error(code, "Checking access to the hphcs_ gate.", "", ""); else if code = error_table_$moderr then call report_error(code, "Execute access is required on the hphcs_ gate.", "", ""); end; end; %page; if ^deadproc & owner_sw then; else if owner_sw then do; if (person_proj = ename) then call report_error(error_table_$action_not_performed, "Cannot construct person.project from name given ^a.", ename, ""); end; else person_proj = ""; /* only need */ /* person.project*/ /* if owner given*/ /* target dir */ /* exist already?*/ call hcs_$status_minf (target_dir, pdir_to_create, no_chase, type, ignore, code); if code = 0 then do; /* yes, rename it*/ restore_names = TRUE; call upd_free_name_$retain_suffix (target_dir, pdir_to_create, "pdir", code); if code ^= 0 then call report_error(code, "While renaming the pdir directory ^a", pathname_(target_dir, pdir_to_create), ""); end; /* set 256K sw */ /* just in case */ call hcs_$set_256K_switch ( "11"b, old_256k_sw, code); if code ^= 0 then call com_err_(myname, code, "Warning, unable to set the 256K switch...continuing copying."); if deadproc /* copy the pdir */ then call copy_pdir_$deadproc (myname, dirname, ename, target_dir, pdir_to_create, person_proj, need_hphcs, code); else call copy_pdir_$liveproc (myname, dirname, ename, target_dir, pdir_to_create, person_proj, need_hphcs, before(name_str,"."), code); if code ^= 0 then call report_error(code, "While copying ^a to ^a.", pathname_(dirname, ename), pathname_(target_dir, pdir_to_create)); restore_names = FALSE; /* successful copy, dont restore */ end; if delete_sw | ncd_sw then do; call copy_pdir_$delete (myname, dirname, ename, code); if code ^= 0 then call report_error(code, "Deleting ^a.", pathname_(dirname, ename), ""); end; END_COPY: call clean_up(); EXIT: return; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Reports error messages pertaining to argument processing and aborts the */ /* command. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ argument_error: proc(ecode, message, str1, str2); dcl ecode fixed bin(35), (message, str1, str2) char(*); call com_err_(ecode, myname, message, str1, str2); goto EXIT; end argument_error; /* * * * * * * * * * * * * * * * * * * * * * * * * */ %page; /* * * * * * * * * * * * * * * * * * * * * * * * * */ clean_up: proc(); dcl code fixed bin(35); code = 0; if restore_names then call upd_free_name_$restore_with_suffix (target_dir, pdir_to_create, "pdir", ignore_code); restore_names = FALSE; if privileges_are_set then do; if ^(privileges.dir) then call system_privilege_$dir_priv_off (ignore_code); if ^(privileges.seg) then call system_privilege_$seg_priv_off (ignore_code); end; call hcs_$set_256K_switch (old_256k_sw, (""b), ignore_code); end clean_up; /* * * * * * * * * * * * * * * * * * * * * * * * * */ %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Attempts to construct the person.pdir name for the target pdir name and */ /* the person.project for the owner acl. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ construct_names_from_pdir: proc (old_name, new_name, acl_name); dcl acl_name char(*); dcl new_name char(*); dcl old_name char(*); dcl temp_name char(32) var; dcl temp_idx fixed bin; /* old_name is assumed to be at the very least person.project */ acl_name, new_name = ""; temp_name = rtrim(old_name); temp_idx = index(old_name, "."); if temp_idx ^= 0 then new_name = substr(temp_name, 1, temp_idx-1); else /* doesn't appear to be a person.project */ new_name = old_name; /* return as is */ new_name = rtrim(new_name) || "." || PDIR_SUFFIX; /* To construct person.project, the old name is assumed to be of the form person.project.f.channel */ temp_idx = index(temp_name, ".f."); if temp_idx ^= 0 then acl_name = substr(temp_name, 1, temp_idx-1); else /* doesn't appear to be a person.project.f.chnl */ acl_name = old_name; /* return as is */ end construct_names_from_pdir; /* * * * * * * * * * * * * * * * * * * * * * * * * */ %page; /* * * * * * * * * * * * * * * * * * * * * * * * * */ determine_hphcs_need: proc(dirname, ename, person_proj) returns(bit(1)); dcl dirname char(168); dcl ename char(32); dcl person_proj char(32); dcl code fixed bin(35); dcl userid char(32); dcl get_group_id_ entry() returns(char(32)); dcl get_group_id_$tag_star entry() returns(char(32)); userid = get_group_id_$tag_star(); if person_proj = substr(userid, 1, index(userid, ".*")-1) then return("0"b); else do; call hcs_$get_user_effmode (dirname, ename, get_group_id_(), -1, mode, code); if code ^= 0 then call report_error(code, "^a", dirname, ""); if mode = SMA_ACCESS_BIN then do; call hcs_$get_user_effmode (pathname_ (dirname, ename), "pit", get_group_id_(), -1, mode, code); if mode = REW_ACCESS_BIN then return ("0"b); else return ("1"b); end; else return("1"b); end; end determine_hphcs_need; /* * * * * * * * * * * * * * * * * * * * * * * * * */ %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This guy gets the next argument from the argument string, complaining */ /* if it's not there. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ get_next_arg: proc(arg_expected, ap1, al1); dcl arg_expected char(*); dcl (ap1 ptr, al1 fixed bin(21), code fixed bin(35)); argno = argno + 1; if argno > nargs then do; call argument_error(error_table_$noarg, "A ^a expected after ^a.", arg_expected, arg); return; end; call cu_$arg_ptr (argno, ap1, al1, code); if code ^= 0 then call argument_error(code, "get_next_arg", "", ""); end get_next_arg; /* * * * * * * * * * * * * * * * * * * * * * * * * */ %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* reports error messages and aborts the line. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ report_error: proc(ecode, message, str1, str2); dcl ecode fixed bin(35), (message, str1, str2) char(*); call com_err_(ecode, myname, message, str1, str2); goto END_COPY; end report_error; /* * * * * * * * * * * * * * * * * * * * * * * * * */ %page; /* * * * * * * * * * * * * * * * * * * * * * * * * */ set_privileges: proc(code); dcl code fixed bin(35); code = 0; priv_string = get_privileges_(); /* first make sure they have re to system_privileges_ gate */ call check_gate_access_ ("system_privilege_", null(), code); if code ^= 0 then return; if privileges.dir then; /* caller already has it on */ else call system_privilege_$dir_priv_on (code); if privileges.seg then; /* caller already has it on */ else call system_privilege_$seg_priv_on (code); privileges_are_set = "1"b; end set_privileges; /* * * * * * * * * * * * * * * * * * * * * * * * * */ %page;%include access_mode_values; %page;%include aim_privileges; end copy_deadproc;  copy_pdir_.pl1 03/15/89 0850.8rew 03/15/89 0759.6 286650 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ copy_pdir_: proc(); /* format: off */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This is a tool to copy process directories from the >pdd directory. */ /* */ /* Status: */ /* */ /* 0) Created: June 1984 by B. Braun */ /* 1) Modified: 30 Nov 84 by B. Braun to: */ /* - remove call to hcs_$get_access_class from copy_pdir. It's not needed. */ /* - correct the cleanup handler to not delete the newly copied dir when it */ /* can't delete the original one. */ /* 2) Modified: 20 Jan 85 by B. Braun to remove write acces off the initial acl for segs. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /****^ HISTORY COMMENTS: 1) change(87-07-18,GDixon), approve(88-03-09,MCR7861), audit(88-07-08,Farley), install(88-07-12,MR12.2-1055): A) Add copy_pdir_$liveproc entrypoint. B) Add special-casing for copying Initializer liveproc. C) Correct references to names returned by hcs_$star_. 2) change(87-11-11,GDixon), approve(88-03-09,MCR7861), audit(88-07-08,Farley), install(88-07-12,MR12.2-1055): A) Change copy_pdir internal proc to copy through links in the process directory. The pdir usually does not contain links. If such links exist, it probably means the user has placed them there to force copy_deadproc or copy_liveproc to copy some segment not normally kept in the pdir. 3) change(89-02-27,TLNguyen), approve(89-02-27,MCR8049), audit(89-02-28,Parisek), install(89-03-15,MR12.3-1025): Replaced create_branch_version_1 with create_branch_version_2. END HISTORY COMMENTS */ dcl adjust_bit_count_ entry (char(168), char(32), bit(1) aligned, fixed bin(35), fixed bin(35)); dcl amu_$dp_create_uid_hash entry (char(*), fixed bin(35)); dcl com_err_ entry() options(variable); dcl cv_bin_$dec entry (fixed bin, char(12) aligned); dcl cv_bin_$oct entry (fixed bin, char(12) aligned); dcl cv_userid_ entry (char(*)) returns(char(32)); dcl delete_$path entry (char(*), char(*), bit(36) aligned, char(*), fixed bin(35)); dcl delete_$ptr entry (ptr, bit(36) aligned, char(*), fixed bin(35)); dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); dcl get_ring_ entry() returns(fixed bin(3)); dcl get_system_free_area_ entry returns (ptr); dcl (hcs_$add_acl_entries, hphcs_$add_acl_entries) entry (char(*), char(*), ptr, fixed bin, fixed bin(35)); dcl hcs_$add_dir_acl_entries entry (char(*), char(*), ptr, fixed bin, fixed bin(35)); dcl hcs_$add_dir_inacl_entries entry (char(*), char(*), ptr, fixed bin, fixed bin(3), fixed bin(35)); dcl hcs_$add_inacl_entries entry (char(*), char(*), ptr, fixed bin, fixed bin(3), fixed bin(35)); dcl hcs_$create_branch_ entry (char(*), char(*), ptr, fixed bin(35)); dcl hcs_$fs_move_file entry (char(*), char(*), fixed bin(2), char(*), char(*), fixed bin(35)); dcl hcs_$get_uid_seg entry (ptr, bit(36) aligned, fixed bin(35)); dcl hcs_$make_seg entry (char(*), char(*), char(*), fixed bin(5), ptr, fixed bin(35)); dcl hcs_$set_bc entry (char(*), char(*), fixed bin(24), fixed bin(35)); dcl hcs_$set_dir_ring_brackets entry (char(*), char(*), (2)fixed bin(3), fixed bin(35)); dcl hcs_$set_max_length_seg entry (ptr, fixed bin(19), fixed bin(35)); dcl hcs_$set_ring_brackets entry (char(*), char(*), (3)fixed bin(3), fixed bin(35)); dcl hcs_$star_ entry (char(*), char(*), fixed bin(2), ptr, fixed bin, ptr, ptr, fixed bin(35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl hphcs_$set_dir_ring_brackets entry (char(*), char(*), (3)fixed bin(3), fixed bin(35)); dcl hphcs_$set_ring_brackets entry (char(*), char(*), (3)fixed bin(3), fixed bin(35)); dcl get_group_id_$tag_star entry() returns(char(32)); dcl get_pdir_ entry() returns(char(168)); dcl nd_handler_ entry (char(*), char(*), char(*), fixed bin(35)); dcl pathname_ entry (char(*), char(*)) returns(char(168)); dcl phcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl ring0_get_$segptr entry (char(*), char(*), ptr, fixed bin(35)); dcl ring_zero_peek_ entry (ptr, ptr, fixed bin(19), fixed bin(35)); dcl ring_zero_peek_$by_definition entry (char(*), char(*), fixed bin(18), ptr, fixed bin(19), fixed bin(35)); dcl system_info_$sysid entry (char(*)); dcl terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35)); dcl ( error_table_$action_not_performed, error_table_$empty_file, error_table_$infcnt_non_zero, error_table_$namedup, error_table_$nomatch, error_table_$segknown ) fixed bin(35) ext static; /* Options Constant */ dcl ( CHASE init(1) fixed bin(1), HC_SEGS (4) char(12) init("slt", "name_table", "definitions_", "dseg"), NL char(1) init(" "), NO_CHASE init(0) fixed bin(1), myname char(10) init("copy_pdir_") ) int static options(constant); dcl 1 DIR_ACL_INIT (5) aligned int static options(constant), 2 access_name char (32) unal init("*.*.*", "*.SysMaint.*", "*.SysAdmin.*", "*.SysDaemon.*", ""), 2 mode bit (36) aligned /* null for *.*.*, sma access for the rest */ init( (1) ((36) "0"b), (3) ("111"b || (33)"0"b), (1) ("100"b || (33)"0"b)), 2 status_code fixed bin (35) init((5) 0); dcl 1 SEG_ACL_INIT (5) aligned int static options(constant), 2 access_name char (32) unal init("*.*.*", "*.SysMaint.*", "*.SysAdmin.*", "*.SysDaemon.*", ""), 2 mode bit (36) aligned /* null for *.*.*, r access for the rest */ init( (1) ((36) "0"b), (3) ("100"b || (33)"0"b), (1) ("100"b || (33)"0"b)), 2 extended_mode bit (36) aligned init((5) (36)"0"b), /* we dont use this */ 2 status_code fixed bin (35) init((5) 0); /* Builtins */ dcl (addr, addrel, baseno, baseptr, binary, fixed, hbound, lbound, length, ltrim, null, rtrim, size, substr, string ) builtin; /* Condition handlers */ dcl (cleanup) condition; /* Based variables */ dcl system_area area based (system_area_ptr); /* Automatic */ dcl code fixed bin (35); dcl dead_pdir_ring fixed bin(3); dcl deadproc bit(1); dcl dir_acl_ptr ptr; dcl dir_path char(168); dcl i fixed bin; dcl ignore fixed bin (24); dcl iocb_ptr ptr; dcl live_process char(32); dcl owner_acl char(32); dcl owner_sw bit(1); dcl pdir_path char(168); dcl pdir_to_create char(32); dcl process_dir char(168); dcl seg_acl_ptr ptr; dcl system_area_ptr ptr; dcl type fixed bin (2); /* branch type from status_minf */ dcl user_acl char(32); %page; copy_pdir_$deadproc: entry (caller, copy_dirname, copy_entryname, a_pdir_path, a_pdir_name, a_owner_acl, a_need_hphcs, a_code); /* This entry copies a dead processes. Arguments are: caller Name of who called me. (Input) copy_dirname Pathname of the containing directory of the source pdir. (Input) copy_entryname Name of the process directory to be copied. (Input) a_pdir_path Pathname of the containing directory where the process will be copied. (Input) a_pdir_name Name of the target pdir to be created. (Input) a_owner_acl Person.Project to be added as an acl to the target pdir. (Input) a_need_hphcs This means that the copying is being done on behalf of the owner of the pdir. (Input) a_code Standard system error code. (Output) */ /* parameters */ dcl a_code fixed bin(35); dcl a_live_process char(*); dcl a_owner_acl char(*); dcl a_need_hphcs bit(1); dcl a_pdir_path char(*); dcl a_pdir_name char(*); dcl caller char(*); dcl copy_dirname char(168); dcl copy_entryname char(32); deadproc = "1"b; live_process = ""; go to COMMON; copy_pdir_$liveproc: entry (caller, copy_dirname, copy_entryname, a_pdir_path, a_pdir_name, a_owner_acl, a_need_hphcs, a_live_process, a_code); deadproc = "0"b; live_process = a_live_process; go to COMMON; COMMON: dir_path = a_pdir_path; star_entry_count = 0; /* necessary to reference to avoid a warning */ pdir_to_create = a_pdir_name; if a_owner_acl = "" then owner_sw = "0"b; else do; owner_acl = cv_userid_ (a_owner_acl); owner_sw = "1"b; end; if a_need_hphcs then user_acl = get_group_id_$tag_star(); else user_acl = ""; code = 0; iocb_ptr = null(); system_area_ptr = get_system_free_area_(); acl_count = 5; dir_acl_ptr, seg_acl_ptr = null (); process_dir = ""; on cleanup begin; call clean_up(); end; allocate directory_acl_array in (system_area) set (dir_acl_ptr); allocate segment_acl_array in (system_area) set (seg_acl_ptr); call setup_pdir_uids (pathname_(copy_dirname, copy_entryname), process_dir, iocb_ptr, code); if code ^= 0 then goto END_COPY_PDIR; call get_pdir_rbs(pdir_path, dead_pdir_ring); call copy_pdir (copy_dirname, copy_entryname, dir_path, pdir_to_create, owner_sw, owner_acl, user_acl, iocb_ptr, dead_pdir_ring, code); if code ^= 0 then goto END_COPY_PDIR; call cleanup_pdir_uids (iocb_ptr); pdir_path = pathname_(dir_path, pdir_to_create); call move_pdir_uid_seg(pdir_path, process_dir, code); if code ^= 0 then goto END_COPY_PDIR; do i = lbound(HC_SEGS,1) to hbound(HC_SEGS,1)-1, hbound(HC_SEGS,1) while (live_process = "Initializer"); call copy_segment ("", HC_SEGS(i), pdir_path, ""b, code); if code ^= 0 then goto END_COPY_PDIR; end; call determine_stack_base (pdir_path, code); if code ^= 0 then goto END_COPY_PDIR; call amu_$dp_create_uid_hash (pdir_path, code); if code ^= 0 then goto END_COPY_PDIR; if owner_sw then do; call set_hash_access(pdir_path, owner_acl, code); if code ^= 0 then goto END_COPY_PDIR; call set_owner_status (pdir_path, owner_acl, code); if code ^= 0 then goto END_COPY_PDIR; end; END_COPY_PDIR: a_code = code; call clean_up(); return; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ copy_pdir_$delete: entry (caller, a_pdir_path, a_pdir_name, a_code); /* This entry deletes a dead process. Currently, it expects to be called by copy_deadproc after being called by copy_pdir_$deadproc, so access and ring brackets are assumed to be set up already. */ code = 0; string (delete_options) = ""b; delete_options.force, delete_options.directory = "1"b; call delete_$path (a_pdir_path, a_pdir_name, string (delete_options), caller, code); if code = error_table_$action_not_performed then /* maybe only partially deleted */ call delete_$path (a_pdir_path, a_pdir_name, string (delete_options), caller, code); if code = error_table_$infcnt_non_zero then /* The directory is successfully deleted. */ code = 0; /* So, ignore the code */ a_code = code; return; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ add_inacls: proc (dirname, ename, owner_sw, owner_acl, code); dcl (dirname, ename) char(*); dcl code fixed bin(35); dcl owner_sw bit(1); dcl owner_acl char(*); /* set initial acls for segments */ acl_count = 5; seg_acl_ptr -> segment_acl_array(*) = SEG_ACL_INIT(*); if owner_sw then seg_acl_ptr -> segment_acl_array(5).access_name = owner_acl; else acl_count = 4; call hcs_$add_inacl_entries (dirname, ename, seg_acl_ptr, acl_count, 4, code); if code ^= 0 then return; /* add initial acls for directories */ acl_count = 5; dir_acl_ptr -> directory_acl_array(*) = DIR_ACL_INIT(*); if owner_sw then dir_acl_ptr -> directory_acl_array (5).access_name = owner_acl; else acl_count = 4; call hcs_$add_dir_inacl_entries (dirname, ename, dir_acl_ptr, acl_count, 4, code); if code ^= 0 then return; end add_inacls; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ clean_up: proc(); dcl ignore_code fixed bin (35); if dir_acl_ptr ^= null() then free dir_acl_ptr -> directory_acl_array in (system_area); if seg_acl_ptr ^= null() then free seg_acl_ptr -> segment_acl_array in (system_area); if iocb_ptr ^= null() then do; call iox_$close (iocb_ptr, ignore_code); call iox_$detach_iocb (iocb_ptr, ignore_code); end; if process_dir ^= "" then do; string (delete_options) = ""b; delete_options.force, delete_options.segment = "1"b; call delete_$path (process_dir, "pdir_info", string (delete_options), caller, ignore_code); end; if code ^= 0 then do; /* delete the partially copied pdir */ string (delete_options) = ""b; delete_options.force, delete_options.segment, delete_options.directory = "1"b; call delete_$path (dir_path, pdir_to_create, string (delete_options), caller, ignore_code); end; end clean_up; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ cleanup_pdir_uids: proc(iocb_ptr); /* parameters */ dcl (iocb_ptr) ptr; dcl ignore_code fixed bin (35); if iocb_ptr ^= null() then do; call iox_$close (iocb_ptr, ignore_code); call iox_$detach_iocb (iocb_ptr, ignore_code); end; end cleanup_pdir_uids; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ copy_pdir: proc (dirname, ename, target_dirname, target_ename, owner_sw, owner_acl, user_acl, iocbp, pdir_ring, code) recursive; /* Parameters */ dcl dirname char(*); dcl ename char(*); dcl code fixed bin(35); dcl iocbp ptr; dcl owner_acl char(*); dcl owner_sw bit(1); dcl pdir_ring fixed bin(3); dcl target_dirname char(*); dcl target_ename char(*); dcl user_acl char(*); /* automatic */ dcl 1 cbi like create_branch_info; dcl dir_path char(168); dcl i fixed bin; dcl line_ptr ptr; dcl n_write fixed bin(21); dcl need_to_set_rbs bit(1); dcl pdir_line char(45); dcl 1 s_entries (s_entry_count) aligned based (s_entry_ptr) like star_entries; dcl s_entry_count; dcl s_entry_ptr ptr; dcl s_names_ptr ptr; dcl s_names (500) char(32) aligned based ( s_names_ptr); dcl t_parent char(168); dcl t_ename char(32); dcl target_dir_path char(168); dcl type fixed bin (2); /* branch type from status_minf */ dcl unique_id bit(36) aligned; need_to_set_rbs = (pdir_ring ^= get_ring_()); line_ptr = addr (pdir_line); n_write = length(pdir_line); dir_path = pathname_(dirname, ename); target_dir_path = pathname_(target_dirname, target_ename); s_entry_ptr, s_names_ptr = null (); code = 0; on condition (cleanup) begin; if s_names_ptr ^= null () then free s_names in (system_area); if s_entry_ptr ^= null () then free s_entries in (system_area); end; /* create directory */ call expand_pathname_ (target_dirname, t_parent, t_ename, code); if code ^= 0 then return; cbi.version = create_branch_version_2; cbi.dir_sw, cbi.copy_sw, cbi.parent_ac_sw = "1"b; cbi.chase_sw, cbi.priv_upgrade_sw, cbi.mbz1, cbi.mbz2 = "0"b; cbi.bitcnt, cbi.quota = 0; cbi.mode = SMA_ACCESS; cbi.rings(*) = 4; cbi.userid = get_group_id_$tag_star(); cbi.access_class = ""b; cbi.dir_quota = 0; call hcs_$create_branch_ (target_dirname, target_ename, addr(cbi), code); if code ^= 0 then return; call add_inacls (target_dirname, target_ename, owner_sw, owner_acl, code); if code ^= 0 then return; call hcs_$star_ (dir_path, "**", star_ALL_ENTRIES, system_area_ptr, s_entry_count, s_entry_ptr, s_names_ptr, code); if code ^= 0 then do; /* copy thru links in pdir. */ /* an attempt to be more descriptive */ if code = error_table_$nomatch then code = error_table_$empty_file; goto ERROR_COPY; end; /* Any errors found are handled in the clean_up routine */ do i = 1 to s_entry_count; t_ename = s_names(s_entries(i).nindex); if s_entries(i).type = star_LINK then do; /* Find type of link target. */ call hcs_$status_minf (dir_path, t_ename, CHASE, type, ignore, code); if code = 0 then s_entries(i).type = type; end; if s_entries(i).type = star_SEGMENT then do; if live_process = "Initializer" & t_ename = "template_pit" then t_ename = s_names(s_entries(i).nindex-1+s_entries(i).nnames); /* Initializer has both template_pit and pit names */ /* on its pit, but azm looks only for pit. */ if user_acl ^= "" then call set_rb_and_access(dir_path, t_ename, "0"b, user_acl, code); if code ^= 0 then goto ERROR_COPY; call copy_segment (dir_path, t_ename, target_dir_path, unique_id, code); if code ^= 0 then goto ERROR_COPY; if need_to_set_rbs then call set_owner_rbs (target_dir_path, t_ename, "0"b, pdir_ring, code); if code ^= 0 then goto ERROR_COPY; call save_pdir_uid (iocbp, unique_id, t_ename, pdir_line, line_ptr, n_write, code); if code ^= 0 then goto ERROR_COPY; end; else if s_entries(i).type = star_DIRECTORY then do; if user_acl ^= "" then call set_rb_and_access(dir_path, t_ename, "1"b, user_acl, code); if code ^= 0 then goto ERROR_COPY; if need_to_set_rbs then call set_owner_rbs (target_dir_path, t_ename, "1"b, pdir_ring, code); if code ^= 0 then goto ERROR_COPY; call copy_pdir(dir_path, t_ename, target_dir_path, t_ename, owner_sw, owner_acl, user_acl, iocbp, pdir_ring, code); if code ^= 0 then goto ERROR_COPY; end; end; ERROR_COPY: if s_names_ptr ^= null () then free s_names in (system_area); if s_entry_ptr ^= null () then free s_entries in (system_area); return; end copy_pdir; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ copy_segment: proc (dirname, seg_to_copy, target_dirname, unique_id, code); /* parameters */ dcl code fixed bin(35); dcl dirname char(*); dcl seg_to_copy char(*); dcl target_dirname char(*); dcl unique_id bit(36) aligned; dcl bit_count fixed bin(24); dcl bound fixed bin(19); dcl bc_35 fixed bin(35); dcl ename char(32); dcl got_copy bit(1); dcl segptr ptr; dcl segptr0 ptr; dcl test_word fixed bin (35); dcl tsdw fixed bin (71); segptr, segptr0 = null(); got_copy = "0"b; code = 0; ename = seg_to_copy; if dirname = "" then /* get from the system */ call ring0_get_$segptr ("", ename, segptr0, code); else call phcs_$initiate (dirname, ename, "", 0, 0, segptr0, code); if segptr0 = null then return; /* Get unique ID for later use. */ if dirname = "" then unique_id = ""b; else call hcs_$get_uid_seg (segptr0, unique_id, code); /* Test whether copying is possible, and also cause segment fault to get sdw.bound right */ call ring_zero_peek_ (segptr0, addr (test_word), size (test_word), code); if code ^= 0 then goto RZP_ERROR; call ring_zero_peek_ (addr (baseptr (0) -> sdwa (binary (baseno (segptr0), 15))), addr (tsdw), size (tsdw), code); if code ^= 0 then goto RZP_ERROR; bound = (binary (addr (tsdw) -> sdw.bound, 14) + 1) * 16; /* get number of words */ bit_count = bound * 36; /* bit of segment */ call ring_zero_peek_ (addrel (segptr0, bound - 1), addr (test_word), size (test_word), code); if code ^= 0 then /* test whether whole segment is copyable -- in case we're */ goto RZP_ERROR; /* stuck with using metering_ring_zero_peek_ */ on cleanup call rzd_cleanup(); CREATE: /* get segment to copy data into */ if live_process = "Initializer" & ename = "kst_seg" then/* Initializer has nonstandard name for its kst */ ename, seg_to_copy = "kst"; call hcs_$make_seg (target_dirname, ename, "", RW_ACCESS_BIN, segptr, code); if code ^= 0 then if code = error_table_$namedup then do; call nd_handler_ (myname, dirname, ename, code); if code = error_table_$action_not_performed then return; goto CREATE; end; else if code ^= error_table_$segknown then return; call ring_zero_peek_ (segptr0, segptr, bound, code); /* copy segment into user ring */ if code ^= 0 then goto RZP_ERROR; got_copy = "1"b; /* set bit count and terminate the segment */ call adjust_bit_count_((target_dirname), ename, "1"b, bc_35, code); bit_count = bc_35; call terminate_file_(segptr, bit_count, TERM_FILE_TRUNC_BC_TERM, (0)); return; RZP_ERROR: call com_err_ (code, myname, "This operation requires access to phcs_."); call rzd_cleanup (); return; rzd_cleanup: proc (); if segptr ^= null & ^got_copy then do; string (delete_options) = ""b; delete_options.force, delete_options.segment = "1"b; call delete_$path (dirname, ename, string(delete_options), myname, (0)); end; end rzd_cleanup; end copy_segment; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ determine_stack_base: proc(dirname, code); /* This procedure determines the stack_0 segment number for this boot of the system. Then it */ /* creates a segment with max length of 0 called stack0_is_NNN where NNN is the segment number. */ /* This way, analyze_multics, who uses stack0 can find the correct segno for processes analyzed */ /* across system boots (where the segno may change). */ dcl dirname char(*); dcl code fixed bin(35); dcl stackbase_segno fixed bin(35); dcl tbase char(12) aligned; dcl stack_base char(32); dcl segptr ptr; code = 0; segptr = null(); stack_base, tbase = ""; stackbase_segno = -1; call ring_zero_peek_$by_definition ("active_all_rings_data", "stack_base_segno", 0, addr(stackbase_segno), 1, code); if code ^= 0 then return; call cv_bin_$dec (fixed(stackbase_segno, 17), tbase); stack_base = "stack_base_" || ltrim(tbase); CREATE: /* create a zero length seg with the stack base number */ call hcs_$make_seg (dirname, stack_base, "", R_ACCESS_BIN, segptr, code); if code ^= 0 then if code = error_table_$namedup then do; call nd_handler_ (myname, dirname, stack_base, code); if code = error_table_$action_not_performed then return; goto CREATE; end; else if code ^= error_table_$segknown then return; call hcs_$set_max_length_seg (segptr, 0, code); end determine_stack_base; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_pdir_rbs: proc (dirname, pdir_ring); /* parameters */ dcl dirname char(*); dcl pdir_ring fixed bin(3); dcl code fixed bin(35); dcl i fixed bin; dcl (DEFAULT_RING fixed bin(3) init (4), stacks (0:7) char(7) init("stack_0", "stack_1", "stack_2", "stack_3", "stack_4", "stack_5", "stack_6", "stack_7")) int static options (constant); /* The only time ring brackets have to be set to other than what they are (which is ring 4), is when the user is running in ring 5,6,7. So, we look for the existence of stack_7, stack_6, stack_5 and set ring brackets accordingly. */ pdir_ring = DEFAULT_RING; code = -1; do i = hbound (stacks,1) to 0 by -1 while (code ^= 0); call hcs_$status_minf (dirname, stacks(i), NO_CHASE, type, ignore, code); if code = 0 then pdir_ring = i; end; /* of loop */ end get_pdir_rbs; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ move_pdir_uid_seg: proc (dirname, process_dir, code); dcl dirname char (*); dcl code fixed bin(35); dcl process_dir char(168); dcl bc_35 fixed bin(35); dcl seg_bc fixed bin(24); code = 0; call adjust_bit_count_(process_dir, "pdir_info", "1"b, bc_35, code); seg_bc = bc_35; call hcs_$fs_move_file (process_dir, "pdir_info", fixed("11"b), dirname, "pdir_info", code); if code ^= 0 then return; call hcs_$set_bc (dirname, "pdir_info", seg_bc, code); if code ^= 0 then return; string (delete_options) = ""b; delete_options.force, delete_options.segment = "1"b; call delete_$path (process_dir, "pdir_info", string (delete_options), caller, code); process_dir = ""; end move_pdir_uid_seg; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ save_pdir_uid: proc (iocbp, unique_id, seg_name, putline, putline_ptr, n_write, code); dcl iocbp ptr; dcl code fixed bin(35); dcl unique_id bit(36) aligned; dcl putline_ptr ptr; dcl putline char(*); dcl n_write fixed bin(21); dcl seg_name char(*); dcl tuid char(12) aligned; code = 0; if unique_id = "0"b then return; call cv_bin_$oct(fixed(unique_id, 35), tuid); substr(putline, 1, n_write) = tuid || seg_name || NL; call iox_$put_chars(iocbp, putline_ptr, n_write, code); return; end save_pdir_uid; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ set_hash_access: proc (dir_path, owner_acl, code); /* parameters */ dcl code fixed bin(35); dcl dir_path char(*); dcl owner_acl char(*); /* automatic */ code = 0; acl_count = 1; seg_acl_ptr -> segment_acl_array(1).access_name = owner_acl; seg_acl_ptr -> segment_acl_array(1).mode = R_ACCESS || (33)"0"b; seg_acl_ptr -> segment_acl_array(1).extended_mode = (36)"0"b; call hcs_$add_acl_entries (dir_path, "uid_hash_table", seg_acl_ptr, acl_count, code); end set_hash_access; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ set_owner_status: proc (dir_path, owner_acl, code); /* parameters */ dcl code fixed bin(35); dcl dir_path char(*); dcl owner_acl char(*); /* automatic */ dcl dirname char(168); dcl entryname char(32); /* owner needs s to the containing dir of the just created pdir dir. */ call expand_pathname_ (dir_path, dirname, entryname, code); if code ^= 0 then return; call hcs_$status_minf (dirname, entryname, NO_CHASE, type, ignore, code); if code ^= 0 then return; acl_count = 1; dir_acl_ptr -> directory_acl_array(1).access_name = owner_acl; dir_acl_ptr -> directory_acl_array(1).mode = S_ACCESS || (33)"0"b; call hcs_$add_dir_acl_entries (dirname, entryname, dir_acl_ptr, acl_count, code); end set_owner_status; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ set_owner_rbs: proc (dirname, ename, dir_sw, user_ring, code) recursive; /* parameters */ dcl code fixed bin(35); dcl dirname char(*); dcl dir_sw bit(1); dcl ename char(*); dcl user_ring fixed bin(3); dcl rbs (3) fixed bin(3); dcl drb (2) fixed bin(3); code = 0; if dir_sw then do; drb(1), drb(2) = user_ring; call hcs_$set_dir_ring_brackets(dirname, ename, drb, code); end; else do; /* segment */ rbs(1), rbs(2), rbs(3) = user_ring; call hcs_$set_ring_brackets(dirname, ename, rbs, code); end; end set_owner_rbs; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ set_rb_and_access: proc(dirname, ename, dir_sw, user_acl, code); dcl (dirname, ename) char(*); dcl code fixed bin(35); dcl dir_sw bit(1); dcl user_acl char(*); code = 0; acl_ptr = null(); if dir_sw then do; /* set dir ring bracket if copying on behalf of owner */ call hphcs_$set_dir_ring_brackets(dirname, ename, 7, code); if code ^= 0 then return; /* set directory acl */ acl_count = 1; dir_acl_ptr -> directory_acl_array(1).access_name = user_acl; dir_acl_ptr -> directory_acl_array(1).mode = SMA_ACCESS || (33)"0"b; dir_acl_ptr -> directory_acl_array(1).status_code = 0; call hcs_$add_dir_acl_entries (dirname, ename, dir_acl_ptr, acl_count, code); if code ^= 0 then return; end; else if deadproc then do; /* a deadproc segment */ /* set ring brackets to 4 */ call hphcs_$set_ring_brackets(dirname, ename, 4, code); if code ^= 0 then return; /* set access */ acl_count = 1; seg_acl_ptr -> segment_acl_array(1).access_name = user_acl; seg_acl_ptr -> segment_acl_array(1).mode = R_ACCESS || (33)"0"b; seg_acl_ptr -> segment_acl_array(1).extended_mode = (36)"0"b; seg_acl_ptr -> segment_acl_array(1).status_code = 0; call hcs_$add_acl_entries (dirname, ename, seg_acl_ptr, acl_count, code); if code ^= 0 then return; end; else do; /* a liveproc segment */ /* set access */ acl_count = 1; seg_acl_ptr -> segment_acl_array(1).access_name = user_acl; seg_acl_ptr -> segment_acl_array(1).mode = R_ACCESS || (33)"0"b; seg_acl_ptr -> segment_acl_array(1).extended_mode = (36)"0"b; seg_acl_ptr -> segment_acl_array(1).status_code = 0; call hphcs_$add_acl_entries (dirname, ename, seg_acl_ptr, acl_count, code); if code ^= 0 then return; end; end set_rb_and_access; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ setup_pdir_uids: proc (dp_dirname, process_dir, iocbp, code); /* parameter */ dcl iocbp ptr; dcl code fixed bin(35); dcl process_dir char(168); dcl dp_dirname char(168); /* automatic */ dcl attach_desc char(200); dcl line_ptr ptr; dcl n_write fixed bin(21); dcl pdir_line char(45); dcl segptr ptr; dcl sys_release char(44); segptr, iocbp = null(); code = 0; process_dir = get_pdir_(); on cleanup begin; if segptr ^= null() then call delete_$ptr (segptr, "101100"b, myname, (0)); end; call hcs_$make_seg (process_dir, "pdir_info", "", RW_ACCESS_BIN, segptr, code); if segptr = null() then return; attach_desc = "vfile_ " || rtrim (process_dir) || ">pdir_info"; call iox_$attach_name ("pdir_sw", iocbp, attach_desc, null (), code); if code ^= 0 then return; call iox_$open (iocbp, 2, "0"b, code); if code ^= 0 then return; /* Save the system release ID first */ call system_info_$sysid(sys_release); pdir_line = sys_release || NL; line_ptr = addr (pdir_line); n_write = length(pdir_line); call iox_$put_chars(iocbp, line_ptr, n_write, code); end setup_pdir_uids; %page;%include access_mode_values; %page;%include acl_structures; %page;%include create_branch_info; %page;%include delete_options; %page;%include iox_dcls; %page;%include sdw; %page;%include star_structures; %page;%include terminate_file; end copy_pdir_;  hran_.pl1 11/19/84 1248.9rew 11/15/84 1440.1 179451 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ hran_: proc; return; /* do not enter here */ /* hran_ - history register analyzer written by - E. J. Wallman Oct. 1974 Modified by A. Downing March 1976 to add the set_stream entry for use in Multics HEALS. Also, all calls to ioa_ were changed to ioa_$ioa_switch, and calls to ioa_$nnl were changed to calls to ioa_$ioa_switch_nnl. Modified by RH Morrison in September, 1976 to squeeze the output format into 72 columns. To do this, the octal printout of the history registers was eliminated from hran_$hranl since these registers are printed by cpu_reports_ prior to calling hranl. Modified by J. A. Bush in June 1977 to allow for general use by heals_, ol_dump, and mc_trace. The set_stream entry point was discarded in favor of a switch entry parameter. The long output conditional code was added to allow displaying of octal history registers as well as symbolic data. Re-written in October 1980 by R. L. Coppola to accomodate analysis of registers for the DPS8 CPU which are different in structure and sometimes in length. The DPS8 contains four sets (OU, DU/OU, and 2 APU) of registers each containing 64 double word history registers. However fim will only save the 16 MRU hregs in normal operation, BOS dumps will contain all 64. The analysis routines for the L68 and DPS8 have been placed in seperate external sub-routines, this procedure will make a determination as to which analyzer is appropriate and then call it. */ /* This routine transposed from the original key of GMAP-flat to PL/I-sharp in October, 1974. It decomposes the CP6100 history register data saved in the prds and formats the data into easily readable lines in the order in which the various processor cycles occured. The routine has four entry points which are independent of each other. They are ... hrlgnd_l68_ Print a legend giving the definitions of all flags and symbols used in the output of the l68 analyzer. hrlgnd_dps8_ Print a legend giving the definitions of all flags and symbols used in the output of the dps8 analyzer. hran_bos Set the history register block size to 512 words instead of the normal 128 words. hranl_ Normal entry point for history register analysis. History register block size of 128 words default. display_ Normal entry point for display of history regs. No attempt is made to "thread" them. The interp_sw bit is used to enable interpretation of the registers. All output goes to switch "output_switch". If a null iocb pointer is passed, then the switch iox_$user_output is used as a default. Otherwise "output_switch" is used as it is passed. If the long_output_sw = "0"b, then the octal contents of the history registers are not printed, therefore allowing the output to fit on an 80 character wide terminal. If the long_output_sw = "1"b, then the octal contents of the history registers is displayed as well as symbolic data. */ /* ENTRIES */ dcl ioa_$ioa_switch options (variable), ioa_$ioa_switch_nnl entry options (variable), ioa_$rsnnl entry options (variable); dcl hran_l68_$hranl_l68_ entry (ptr, ptr, bit (1)); dcl hran_dps8_$hranl_dps8_ entry (ptr, ptr, fixed bin, bit (1)); dcl hran_l68_$hranl_l68_bos entry (ptr, ptr, bit (1)); dcl hran_l68_$bos_no_thread entry (ptr, ptr, bit (5)); dcl hran_dps8_$no_thread entry (ptr, ptr, fixed bin, bit (5)); dcl hran_l68_$no_thread entry (ptr, ptr, bit (5)); /* PARAMETERS */ dcl (hr_data_ptr, a_iocbp) ptr; dcl lo_sw bit (1); dcl switches bit (5); /* switches to display */ /* each hreg and how to display it */ /* must be in the following order */ /* expand_sw */ /* ou, cu, apu, du */ /* AUTOMATIC STORAGE */ dcl iocbp ptr, /* output switch name */ iox_$user_output ptr ext, /* default io switch */ lo fixed; /* long output sw, 1 => long output 2 => short output */ dcl 1 apu_or_du_word aligned based (apu_or_duhrp), /* first word of the apu or du regs */ (2 PAD bit (71), 2 apu_or_du_bit bit (1) unaligned); /* always on for a L68 CPU */ dcl ou_block1 bit (36 * 2 * 16) based; /* and the second */ dcl (apu_or_duhrp, ouhrp) ptr; dcl nregs fixed bin; dcl threaded bit (1); /* OTHER */ dcl null builtin; %page; hran_bos: entry (hr_data_ptr, a_iocbp, lo_sw); threaded = "1"b; go to COMMON_BOS; bos_no_thread: entry (hr_data_ptr, a_iocbp, switches); threaded = "0"b; COMMON_BOS: /* Regs have been saved as a result of a crash (by BOS), need to determine the type of CPU they are from */ ouhrp = addrel (hr_data_ptr, 32); /* set ptr to second block of ou data */ if ouhrp -> ou_block1 = "0"b then do; /* if empty these are from a l68 */ if threaded = "1"b then call hran_l68_$hranl_l68_bos (hr_data_ptr, a_iocbp, lo_sw); /* for now do same one */ else call hran_l68_$bos_no_thread (hr_data_ptr, a_iocbp, switches); return; end; else do; /* not empty, regs are from a dps8 */ nregs = 64; /* 64 regs each are saved */ if threaded = "1"b then call hran_dps8_$hranl_dps8_ (hr_data_ptr, a_iocbp, nregs, lo_sw); else call hran_dps8_$no_thread (hr_data_ptr, a_iocbp, nregs, switches); return; end; return; %page; hranl: entry (hr_data_ptr, a_iocbp, lo_sw); threaded = "1"b; go to HRANL_COMMON; no_thread: entry (hr_data_ptr, a_iocbp, switches); threaded = "0"b; HRANL_COMMON: /* regs were saved by fim but what type of CPU are they from */ nregs = 16; /* we do know how many regs there are */ apu_or_duhrp = addrel (hr_data_ptr, 64); /* set ptr to appropriate hreg block */ /* Bit 71 of the L68 DU history registers is ALWAYS on, test it to determine CPU type */ if apu_or_du_bit = "1"b then do; /* it is a l68 */ if threaded then call hran_l68_$hranl_l68_ (hr_data_ptr, a_iocbp, lo_sw) ; else call hran_l68_$no_thread (hr_data_ptr, a_iocbp, switches); return; end; else do; /* no, its a dps8 */ if threaded then call hran_dps8_$hranl_dps8_ (hr_data_ptr, a_iocbp, nregs, lo_sw); else call hran_dps8_$no_thread (hr_data_ptr, a_iocbp, nregs, switches); return; end; return; %page; hrlgnd_dps8_: entry (a_iocbp); if a_iocbp = null then /* called to use default switch */ iocbp = iox_$user_output; else iocbp = a_iocbp; call ioa_$ioa_switch (iocbp, "^|Abbreviations used in History Register Analysis for the DPS8 CPU^/^/"); call ioa_$ioa_switch (iocbp, "^2/^12(_^)CU Legend^13(_^)^4x^12(_^)OU Legend^13(_^)"); call ioa_$ioa_switch (iocbp, "cy = cycle type (d = direct operand)^2x^1- >>>flags<<<"); call ioa_$ioa_switch (iocbp, "(i=instr. fetch,o=operand,F=fault)^4xtrgo = transfer condition met"); call ioa_$ioa_switch (iocbp, "(n=indirect,x=xec,*=nop,e=EIS)^8xdl = direct lower operand"); call ioa_$ioa_switch (iocbp, "mc = memory command^2-^8xdu = direct upper operand"); call ioa_$ioa_switch (iocbp, "(00=rrs,sp; 04=rrs,dp; 10=rcl,sp)"); call ioa_$ioa_switch (iocbp, "(12=rmsk,sp; 16=rmsk,dp; 20=cwr,sp)"); call ioa_$ioa_switch (iocbp, "(24=cwr,dp; 32=smsk,sp; 36=smsk,dp)"); call ioa_$ioa_switch (iocbp, "(40=rd/lck; 54=rgr; 56=sgr)"); call ioa_$ioa_switch (iocbp, "(60=wrt/ulck; 62=con; 66=xec; 72=sxc)"); call ioa_$ioa_switch (iocbp, "^1->>>flags<<<"); call ioa_$ioa_switch (iocbp, "-y = memory address invalid^8x<<>>"); call ioa_$ioa_switch (iocbp, "priv = PRIV mode^2-^8xzero = zero indicator"); call ioa_$ioa_switch (iocbp, "inf = instruction fetch cycle^7xsign = sign indicator"); call ioa_$ioa_switch (iocbp, "xint = execute interrupt cycle^7xcarry = carry indicator"); call ioa_$ioa_switch (iocbp, "dir = direct operand^1-^8xovfl = overflow indicator"); call ioa_$ioa_switch (iocbp, "pfa = prepare fault address^1-^8xeovfl = exponent overflow "); call ioa_$ioa_switch (iocbp, "ic = IC value is odd^1-^8xeufl = exponent underflow"); call ioa_$ioa_switch (iocbp, "its = AR/PR reference^1-^8xoflm = overflow mask"); call ioa_$ioa_switch (iocbp, "inh = inhibited instruction^1-^8xhex = hex mode"); call ioa_$ioa_switch (iocbp, "poa = prepare operand address"); call ioa_$ioa_switch (iocbp, "pai = prepare interrupt address"); call ioa_$ioa_switch (iocbp, "pia = prepare instruction address"); call ioa_$ioa_switch (iocbp, "pib = port select logic busy"); call ioa_$ioa_switch (iocbp, "pon = prepare operand next"); call ioa_$ioa_switch (iocbp, "pot = prepare operand tally"); call ioa_$ioa_switch (iocbp, "raw = request alter word"); call ioa_$ioa_switch (iocbp, "riw = request indirect word"); call ioa_$ioa_switch (iocbp, "rpts = executing repeat"); call ioa_$ioa_switch (iocbp, "saw = store alter word"); call ioa_$ioa_switch (iocbp, "siw = store indirect word"); call ioa_$ioa_switch (iocbp, "xde = execute double from even ICT"); call ioa_$ioa_switch (iocbp, "xdo = execute double from odd ICT"); call ioa_$ioa_switch (iocbp, "port = memory cycle went to port"); call ioa_$ioa_switch (iocbp, "internal = memory cycle went to cache or direct"); call ioa_$ioa_switch (iocbp, "^|^/^12(_^)DU Legend^13(_^)^4x^12(_^)APU Legend^12(_^)"); call ioa_$ioa_switch (iocbp, "mc = data mode (b,4,6,9,w)^8xseg# = SDWAMR and PTWAMR numbers if"); call ioa_$ioa_switch (iocbp, "offset = descriptor counter^1-^8xcorresponding MATCH bits are set."); call ioa_$ioa_switch (iocbp, "^1->>>flags<<<^1-^8xoffset = final store address"); call ioa_$ioa_switch (iocbp, "shftg = shift gate^11xmc = ring number (TSR.TRR)"); call ioa_$ioa_switch (iocbp, "d1a = load alpha-num descriptor 1^13x>>>flags<<<"); call ioa_$ioa_switch (iocbp, "d2a = load alpha-num descriptor 2^38tfanp = final address, non-paged"); call ioa_$ioa_switch (iocbp, "anstr = alpha store^38tfap = final address, paged"); call ioa_$ioa_switch (iocbp, "chrcy = character cycle^38tacv/dft = access violation/directed fault"); call ioa_$ioa_switch (iocbp, "d1n = load numeric descriptor 1^38tfdsptw = fetch descriptor segment PTW"); call ioa_$ioa_switch (iocbp, "d2n = load numeric descriptor 2^38tflthld = acv/dft fault waiting"); call ioa_$ioa_switch (iocbp, "gstr = decimal unit store^38tfsdw = fetch SDW"); call ioa_$ioa_switch (iocbp, "lrw1 = load re-write reg 1 (1,2,3)^38tmdsptw = modify descriptor segment PTW"); call ioa_$ioa_switch (iocbp, "lrw2 = load re-write reg 2^38tmptw = modify PTW"); call ioa_$ioa_switch (iocbp, "ndsqf = end of sequence flag^38tfptw = fetch PTW"); call ioa_$ioa_switch (iocbp, "dud = decimal unit idle^38tfptw2 = fetch PTW+1 (for EIS Numerics)"); call ioa_$ioa_switch (iocbp, "duint = decimal unit interrupted^38tptwm = MATCH in PTWAM"); call ioa_$ioa_switch (iocbp, "ndseq = end of sequence^38tsdwm = MATCH in SDWAM"); call ioa_$ioa_switch (iocbp, "adcyc = add cycle^38tcache = cache used for this cycle"); call ioa_$ioa_switch (iocbp, "sp3 = select pointer 3^38tpiapgbsy = instruction fetch across"); call ioa_$ioa_switch (iocbp, "pop = prepare operand pointer^50ta page boundary"); call ioa_$ioa_switch (iocbp, "sp1 = select pointer 1^38tpiaoosb = instruction fetch went"); call ioa_$ioa_switch (iocbp, "sp2 = select pointer 2^50tout of segment bounds"); call ioa_$ioa_switch (iocbp, "lptr1 = Load Pointer #1^38tSDWAM-ERR = Multi-Match/Parity Error"); call ioa_$ioa_switch (iocbp, "lptr2 = Load Pointer #2^50tin SDW Assoc. Memory"); call ioa_$ioa_switch (iocbp, "addgC = add gate C^38tPTWAM-ERR = Multi-Match/Parity Error in"); call ioa_$ioa_switch (iocbp, "swseq = single word sequence^50tPTW Assoc. Memory"); call ioa_$ioa_switch (iocbp, "exh = length exhaust"); call ioa_$ioa_switch (iocbp, "addgE = add gate E"); call ioa_$ioa_switch (iocbp, "addgF = add gate F"); call ioa_$ioa_switch (iocbp, "addgH = add gate H"); call ioa_$ioa_switch (iocbp, "btdgA = binary to decimal gate A"); call ioa_$ioa_switch (iocbp, "dfrst = processing descriptor for^/^8xthe first time."); return; %page; hrlgnd: entry (a_iocbp); /* for compatibility */ hrlgnd_l68_: entry (a_iocbp); if a_iocbp = null then /* called to use default switch */ iocbp = iox_$user_output; else iocbp = a_iocbp; call ioa_$ioa_switch (iocbp, "^|Abbreviations used in History Register Analysis for the L68 CPU^/^/"); call ioa_$ioa_switch (iocbp, "^2/^12(_^)CU Legend^13(_^)^4x^12(_^)OU Legend^13(_^)"); call ioa_$ioa_switch (iocbp, "cy = cycle type (d = direct operand)^2x>>flags<<<"); call ioa_$ioa_switch (iocbp, "(i=instr. fetch,o=operand,F=fault)^4x9b = 9-bit byte (IT modifier only)"); call ioa_$ioa_switch (iocbp, "(n=indirect,x=xec,*=nop,e=EIS)^8xar = A-register in use"); call ioa_$ioa_switch (iocbp, "mc = memory command^2-^8xd1 = first divide cycle"); call ioa_$ioa_switch (iocbp, "(00=rrs,sp; 04=rrs,dp; 10=rcl,sp)^5xd2 = second divide cycle"); call ioa_$ioa_switch (iocbp, "(12=rmsk,sp; 16=rmsk,dp; 20=cwr,sp)^3xdl = direct lower operand"); call ioa_$ioa_switch (iocbp, "(24=cwr,dp; 32=smsk,sp; 36=smsk,dp)^3xdu = direct upper operand"); call ioa_$ioa_switch (iocbp, "(40=rd/lck; 54=rgr; 56=sgr)^1-^8xin = first ou cycle"); call ioa_$ioa_switch (iocbp, "(60=wrt/ulck; 62=con; 66=xec; 72=sxc)^1xit = IT character modifier"); call ioa_$ioa_switch (iocbp, ">>>flags<<<^2-^8xoa = mantissa alignment cycle"); call ioa_$ioa_switch (iocbp, "-y = memory address invalid^1-^8xoe = exponent compare cycle"); call ioa_$ioa_switch (iocbp, "br = BAR mode^2-^8xof = final OU cycle"); call ioa_$ioa_switch (iocbp, "cl = control unit load^1-^8xom = general OU cycle"); call ioa_$ioa_switch (iocbp, "cs = control unit store^1-^8xon = normalize cycle"); call ioa_$ioa_switch (iocbp, "dr = direct operand^2-^8xos = second cycle of multiple ops"); call ioa_$ioa_switch (iocbp, "fa = prepare fault address^1-^8xqr = Q-register in use"); call ioa_$ioa_switch (iocbp, "ic = IC value is odd^1-^8xrb = opcode buffer loaded"); call ioa_$ioa_switch (iocbp, "it = AR/PR reference^1-^8xrp = primary register loaded"); call ioa_$ioa_switch (iocbp, "in = inhibited instruction^1-^8xrs = secondary register loaded"); call ioa_$ioa_switch (iocbp, "ol = operations unit load^1-^8xsd = store data available"); call ioa_$ioa_switch (iocbp, "os = operations unit store^1-^8x-d = data not available"); call ioa_$ioa_switch (iocbp, "pa = prepare operand address^1-^8xx0 = index 0 in use"); call ioa_$ioa_switch (iocbp, "pb = port busy _o_r data from cache^5xx1 = index 1 in use"); call ioa_$ioa_switch (iocbp, "pi = prepare instruction address^6xx2 = index 2 in use"); call ioa_$ioa_switch (iocbp, "pl = port select logic not busy^7xx3 = index 3 in use"); call ioa_$ioa_switch (iocbp, "pn = prepare final indirect address^3xx4 = index 4 in use"); call ioa_$ioa_switch (iocbp, "pt = prepare operand tally^1-^8xx5 = index 5 in use"); call ioa_$ioa_switch (iocbp, "ra = request alter word^1-^8xx6 = index 6 in use"); call ioa_$ioa_switch (iocbp, "ri = request indirect word^1-^8xx7 = index 7 in use"); call ioa_$ioa_switch (iocbp, "rp = executing repeat"); call ioa_$ioa_switch (iocbp, "sa = store alter word"); call ioa_$ioa_switch (iocbp, "si = store indirect word"); call ioa_$ioa_switch (iocbp, "tr = transfer condition met"); call ioa_$ioa_switch (iocbp, "wi = request instruction fetch"); call ioa_$ioa_switch (iocbp, "xa = prepare execute interrupt address"); call ioa_$ioa_switch (iocbp, "xe = execute double from even ICT"); call ioa_$ioa_switch (iocbp, "xi = execute interrupt present"); call ioa_$ioa_switch (iocbp, "xo = execute double from odd ICT"); call ioa_$ioa_switch (iocbp, "^|^/^12(_^)DU Legend^13(_^)^4x^12(_^)APU Legend^12(_^)"); call ioa_$ioa_switch (iocbp, "mc = data mode (b,4,6,9,w)^1-^8xseg# = SDWAMR and PTWAMR numbers if"); call ioa_$ioa_switch (iocbp, "offset = descriptor counter^1-^8xcorresponding MATCH bits are set."); call ioa_$ioa_switch (iocbp, ">>>flags<<<^2-^8xoffset = final store address"); call ioa_$ioa_switch (iocbp, "()a = prepare alignment count for^5xmc = ring number (TSR.TRR)"); call ioa_$ioa_switch (iocbp, "^6xnumeric operand (1,2)"); call ioa_$ioa_switch (iocbp, "a() = load alpha operand (1,2)^8x>>>flags<<<"); call ioa_$ioa_switch (iocbp, "al = adjust length^2-^8xan = final address, non-paged"); call ioa_$ioa_switch (iocbp, "as = alpha store^2-^8xap = final address, paged"); call ioa_$ioa_switch (iocbp, "bd = binary-decimal execution^1-^8xf = access violation or directed fault"); call ioa_$ioa_switch (iocbp, "bg = blanking gate^2-^8xfd = fetch descriptor segment PTW"); call ioa_$ioa_switch (iocbp, "c0 = force stc0^2-^8xfh = fault waiting"); call ioa_$ioa_switch (iocbp, "cg = character operation^1-^8xfs = fetch SDW"); call ioa_$ioa_switch (iocbp, "d() = descriptor active (1,2,3)^7xmd = modify descriptor segment PTW"); call ioa_$ioa_switch (iocbp, "da = data available^2-^8xmp = modify PTW"); call ioa_$ioa_switch (iocbp, "db = decimal-binary execution^1-^8xp1 = fetch PTW"); call ioa_$ioa_switch (iocbp, "dd = decimal unit idle^1-^8xp2 = fetch PTW+1"); call ioa_$ioa_switch (iocbp, "di = decimal unit interrupted^1-^8xpm = MATCH in PTWAM"); call ioa_$ioa_switch (iocbp, "dl = decimal unit load^1-^8xsm = MATCH in SDWAM"); call ioa_$ioa_switch (iocbp, "ds = decimal unit store"); call ioa_$ioa_switch (iocbp, "ei = mid-instruction interrupt enabled"); call ioa_$ioa_switch (iocbp, "en = end instruction"); call ioa_$ioa_switch (iocbp, "es = end sequence"); call ioa_$ioa_switch (iocbp, "ff = floating result"); call ioa_$ioa_switch (iocbp, "fl = first data buffer load"); call ioa_$ioa_switch (iocbp, "fp = first pointer preparation"); call ioa_$ioa_switch (iocbp, "fs = end sequence"); call ioa_$ioa_switch (iocbp, "l() = load descriptor (1,2,3)"); call ioa_$ioa_switch (iocbp, "ld = length = direct"); call ioa_$ioa_switch (iocbp, "lf = end first pointer preparation"); call ioa_$ioa_switch (iocbp, "lv = level < word size"); call ioa_$ioa_switch (iocbp, "lx = length exhaust"); call ioa_$ioa_switch (iocbp, "l< = length < 128"); call ioa_$ioa_switch (iocbp, "mp = executing MOPs"); call ioa_$ioa_switch (iocbp, "n() = load numeric operand (1,2)"); call ioa_$ioa_switch (iocbp, "nd = need descriptor"); call ioa_$ioa_switch (iocbp, "ns = numeric store"); call ioa_$ioa_switch (iocbp, "op = operand available"); call ioa_$ioa_switch (iocbp, "pc = alpha packing cycle"); call ioa_$ioa_switch (iocbp, "pl = prepare operand length"); call ioa_$ioa_switch (iocbp, "pp = prepare operand pointer"); call ioa_$ioa_switch (iocbp, "r() = load rewrite register (1,2)"); call ioa_$ioa_switch (iocbp, "re = write-back partial word"); call ioa_$ioa_switch (iocbp, "rf = rounding"); call ioa_$ioa_switch (iocbp, "rl = rewrite register 1 loaded"); call ioa_$ioa_switch (iocbp, "rw = du=rd+wt control interlock"); call ioa_$ioa_switch (iocbp, "sa = select address register"); call ioa_$ioa_switch (iocbp, "sg = shift procedure"); call ioa_$ioa_switch (iocbp, "xg = exponent network"); call ioa_$ioa_switch (iocbp, "xm = extended al,ql modifier"); call ioa_$ioa_switch (iocbp, "+g = add-subtract execution"); call ioa_$ioa_switch (iocbp, "*g = multiply-divide execution"); return; end hran_;  hran_dps8_.pl1 11/19/84 1249.1rew 11/15/84 1440.1 264843 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Coded August 1980 by Rich Coppola for support of the DPS8M CPU */ /* Modified Oct 1982 by Rich Coppola to make 'threading' work properly. Some notes: The 870M CPU does not append on PIAs unless it crosses a page boundary (apuhr1.piapgbsy). Also direct cycles get entered in the APU hregs even though the APU does nothing. This version of the 'threader' attempts to follow these 'rules' so that the 'analyzed' registers are threaded properly. A new feature has been added as well. If the final address (apuhr1.finadd) of the APU does not agree with the address that the CU developed (cuhr.ca_value) a diagnostic message is displayed. These mismatches may be due to REAL address problems or a failure to strobe the address into the appropriate hreg properly. Modified Oct 1982 by Rich Coppola to add entries for the display of hregs in octal and interpreted, but not threaded, hregs. Modified August 83 by B. Braun to change the long format (when lo_sw is on) to fit neatly on a 80 char screen. Modified 01 Oct 84 by B. Braun to change nregs to be 16, not 64 for bce toehold. */ hran_dps8_: proc; return; /* do not enter here */ /* PARAMETERS */ dcl a_iocbp ptr; dcl lo_sw bit (1); dcl switches bit (5); /* tell what hregs to display and how */ /* must be in this order */ /* expand_sw do_ou do_cu do_au do_du */ /* EXTERNAL DATA */ dcl get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin); dcl ioa_$ioa_switch options (variable), ioa_$ioa_switch_nnl entry options (variable), ioa_$rsnnl entry options (variable); /* default io switch */ /* AUTOMATIC STORAGE */ dcl a_nregs fixed bin; /* auto copy of number of regs */ dcl 1 a_switches based (addr (switches)), (2 expand_sw bit (1), 2 do_ou bit (1), 2 do_cu bit (1), 2 do_au bit (1), 2 do_du bit (1)) unal; dcl (i, j, foo, cusegno, ausegno) fixed bin; dcl PAD (0:10) char (11) var int static options (constant) init ( "", " ", " ", " ", " ", " ", " ", " ", " ", " ", " "); dcl (OP_pad, TAG_pad) char (4) var; dcl AU_index fixed bin, /* AU1 data index */ au_synched bit (1), au2 bit (1), CU_index fixed bin, /* index into CU data */ CU_ptr ptr, /* pointer to CU data */ CY_print char (1), /* cycle type for output */ DU_mode char (1), /* DU execution mode symbol */ IC_cur fixed bin (18) init (1), /* current IC value for CU entries */ IC_next fixed bin (18) init (1), /* next IC value for CU entries */ IC_last fixed bin (18) init (1), /* last IC value for CU lines */ IC_print bit (1), /* sw to print IC value */ IC_value fixed bin (18), /* IC value for output */ LEVEL (0:3) char (1) init ("A", "B", "C", "D"), /* level of ASS MEM for printing */ NOP_flag bit (1) init ("0"b), /* flag for NOP cycles */ OP_cur bit (10) init ((10)"0"b), /* current opcode for CU lines */ OP_last bit (10) init ((10)"0"b), /* last opcode for CU lines */ OP_print char (5) var, /* opcode string for printing */ tpr_ca char (6), TPR_CA_PR char (8) var, DU_OU_ptr ptr, /* pointer to DU_OU data */ DU_OU_synch fixed bin init (0), /* index value at which DU_OU & CU synchronize */ PTW_print char (3), /* PTWAM level and reg# for printing */ SDW_print char (3), /* SDWAM level and reg# for printing */ SEG_print bit (1), /* switch for printing segno */ AUSEG_pr bit (1), /* same for au regs */ (pr_autag, pr_auop, pr_cuop, pr_cutag) bit (1), TAG_cur fixed bin, /* current TAG table index */ TAG_print char (3) var, /* TAG string for printing */ XD1_flag bit (1) init ("0"b), /* flag for 1st of XED pair */ XD2_flag bit (1) init ("0"b), /* flag for 2nd of XED pair */ XEC_flag bit (1) init ("0"b), /* XEC flag */ XED_flag bit (1) init ("0"b), /* XED flag */ AUOP bit (10), /* for display of OP and tag */ AUOP_PR char (5) var, /* in AU2 */ AUTAG fixed bin, AUTAG_PR char (3) var, (temp_char1, temp_char2) char (2), ll_sw bit(1), null builtin, iocbp ptr, /* output switch name */ iox_$user_output ptr ext, /* default io switch */ fetch_count fixed bin init (0), /* fetch cycle count */ pull_count fixed bin init (0); /* index into instruction pull table */ dcl au_cycle_done bit (1) init ("0"b); dcl repeat_count fixed bin init (0), /* OU instruction repeat count */ tag_chain_flag bit (1); /* tag print control flag */ dcl hr_block bit (36*2*4*16) based; /* #of bits in the prds hr data block */ dcl 1 cu_regs (64) based (cuhrp), (2 cu_flags bit (18), 2 cu_op bit (18), 2 cu_addr bit (24), 2 cu_pt_flags bit (12)) unaligned; dcl 1 ou_regs (64) based (du_ouhrp), (2 du_regs bit (36), 2 ou_ic bit (18), 2 ou_rs bit (9), 2 ou_inds bit (9)) unaligned; dcl 1 apu1_regs (64) based (aphrp1), (2 ap1_segno bit (15), 2 ap1_flags1 bit (12), 2 ap1_flags2 bit (8), 2 ap1_flt bit (1), 2 ap1_finadd bit (24), 2 ap1_trr bit (3), 2 ap1_flags3 bit (9)) unaligned; dcl 1 apu2_regs (64) based (aphrp2), (2 ap2_ca bit (18), 2 ap2_op bit (18), 2 ap2_pad bit (36)) unaligned; dcl code fixed bin (35); %page; hranl_dps8_: entry (hr_data_ptr, a_iocbp, nregs, lo_sw); code = 0; call setup; if code ^= 0 then return; /* History regs should be valid, print heading and initialize */ call ioa_$ioa_switch (iocbp, "DPS8 History Register Analysis"); call ioa_$ioa_switch (iocbp, "^/HR ^[^34x^;^10x^]IC or^12xc^3xMemory", lo_sw); call ioa_$ioa_switch_nnl (iocbp, "id^[^9thr contents^8x^;^4t^] Seg# [tpr.ca] opcode tag y Address mc ^[^/^7tflags^;flags^/^]", lo_sw, (lo_sw & ll_sw)); /* Merge CU & OU entries up to fault cycle */ HRA01: IC_last = 0; AU_index = a_nregs + 1; OP_last = "777"b3; au_synched = "0"b; do CU_index = 1 to a_nregs -1; IC_cur = fixed (du_ouhr.ict (CU_index), 18); OP_cur = cuhr.op_code (CU_index); if au_synched = "0"b then call synch_auhr; call cur; OP_last = OP_cur; IC_last = IC_cur; end; /* Do the fault cycles */ do_flt_cycle: IC_cur = fixed (du_ouhr.ict (CU_index), 18); OP_cur = cuhr.op_code (CU_index); call cur; call ioa_$ioa_switch (iocbp, "^/"); return; cur: proc; /* Determine if IC value is to be displayed */ /* if we are repeating _o_r XEC'ing ... */ if cuhr.rpts (CU_index) | XEC_flag then goto cur03; cur02: if (IC_cur ^= IC_last) then do; /* if IC or OP has changed since last CU line ... */ IC_cur = fixed (du_ouhr.ict (CU_index), 18); IC_value = IC_cur; IC_print = "1"b; end; else IC_print = "0"b; /* if IC didn't change, don't print */ if XED_flag then do; /* if XEDing ... */ if ^XD1_flag then do; /* if 1st of XED pair not been done ... */ XD1_flag = "1"b; /* we are about to do it */ goto cur03; end; if ^XD2_flag then do; /* if 2nd of XED pair has not been done ... */ if cuhr.op_code (CU_index) ^= OP_cur then XD2_flag = "1"b; /* we are about to do it */ goto cur03; end; if cuhr.op_code (CU_index) ^= OP_cur then XED_flag, XD1_flag, XD2_flag = "0"b; /* XED finished, reset all flags */ end; cur03: if OP_cur = OP_last & IC_print = "0"b then /* if neither IC nor opcode have changed ... */ pr_cuop = "0"b; /* this must be the same instruction */ else do; OP_cur = cuhr.op_code (CU_index); OP_print = rtrim (OP.code (fixed (OP_cur, 10)+1)); pr_cuop = "1"b; end; cur04: if OP.DUOP (fixed (cuhr.op_code (CU_index), 10)+1) /* if a decimal op ... */ | cuhr.op_code (CU_index) = STCA /* or STCA ... */ | cuhr.op_code (CU_index) = STCQ /* or STCQ ... */ | cuhr.op_code (CU_index) = STBA /* or STBA ... */ | cuhr.op_code (CU_index) = STBQ /* or STBQ ... */ | cuhr.rpts (CU_index) /* or its a repeat */ then do; /* print a blank TAG */ TAG_cur = 0; pr_cutag = "0"b; end; else do; TAG_cur = fixed (cuhr.tag (CU_index), 10)+1; TAG_print = rtrim (TAG.code (TAG_cur)); pr_cutag = "1"b; end; if TAG_cur > 0 then /* if its a true tag ... */ tag_chain_flag = TAG.chain (TAG_cur); /* set tag chain flag */ CY_print = "?"; /* set up for don't know */ if cuhr.pfa (CU_index) then CY_print = "F"; else if cuhr.xint (CU_index) then CY_print = "x"; else if cuhr.pia (CU_index) then do; CY_print = "i"; if cuhr.op_code (CU_index) ^= XED then do; IC_next = fixed (cuhr.ca_value (CU_index), 24); XED_flag, XD1_flag, XD2_flag = "0"b; /* reset XED flags for transfer */ end; else if cuhr.op_code (CU_index) ^= XEC then do; IC_next = fixed (cuhr.ca_value (CU_index), 24); XEC_flag = "0"b; end; end; else if cuhr.riw (CU_index) | cuhr.siw (CU_index) then CY_print = "n"; else if (fixed (cuhr.tag (CU_index), 6) = 3) | (fixed (cuhr.tag (CU_index), 6) = 7) then CY_print = "d"; else if OP.DUOP (fixed (OP_cur, 10)+1) then CY_print = "e"; else if OP_cur = NOP | (OP.TR (fixed (OP_cur, 10)+1) & ^cuhr.rtrgo (CU_index)) then do; CY_print = "*"; NOP_flag = "1"b; end; else if (^cuhr.pia (CU_index)) & (cuhr.poa (CU_index)) then CY_print = "o"; if au_synched = "1"b then if ext_hr.AU1.even (AU_index) ^= "0"b then if apuhr2.opcode (AU_index) = cuhr.op_code (CU_index) then do; cusegno = fixed (apuhr1.esn (AU_index), 15); SEG_print = "1"b; end; else SEG_print = "0"b; if pr_cuop then do; foo = length (OP_print); /* get proper # of pad chars to right justify */ foo = 5 - foo; OP_pad = PAD (foo); OP_print = OP_pad || OP_print; end; if pr_cutag then do; foo = length (TAG_print); /* do same for TAG */ foo = 3 - foo; TAG_pad = PAD (foo); TAG_print = TAG_pad || TAG_print; end; else TAG_print = ""; call ioa_$ioa_switch_nnl (iocbp, "^/CU ^[^12.3b ^12.3b^;^2s^5t^]^[^5o^;^s^5x^] ^[^6o^;^s^6x^] ^[^a^;^s^5x^] ^[^3a^;^s^3x^] ^1a ^8o ^2o ", lo_sw, ext_hr.CU.even (CU_index), ext_hr.CU.odd (CU_index), SEG_print, cusegno, IC_print, IC_value, pr_cuop, OP_print, pr_cutag, rtrim (TAG_print), CY_print, fixed (cuhr.ca_value (CU_index), 24), 2 * fixed (cuhr.pcmd (CU_index), 3)); call ioa_$ioa_switch_nnl (iocbp, "^[^/^7t^]^[pia ^]^[poa ^]^[riw ^]^[siw ^]^[pot ^]^[pon ^]", (lo_sw & ll_sw), cuhr (CU_index).pia, cuhr (CU_index).poa, cuhr (CU_index).riw, cuhr (CU_index).siw, cuhr (CU_index).pot, cuhr (CU_index).pon); call ioa_$ioa_switch_nnl (iocbp, "^[raw ^]^[saw ^]^[inf ^]^[xde ^]^[xdo ^]^[ic ^]^[rpts ^]", cuhr (CU_index).raw, cuhr (CU_index).saw, cuhr (CU_index).pia, cuhr (CU_index).xde, cuhr (CU_index).xdo, cuhr (CU_index).ic, cuhr (CU_index).rpts); call ioa_$ioa_switch_nnl (iocbp, "^[pai ^]^[pfa ^]^[inh ^]^[xint ^]^[pib ^]^[its ^]", cuhr (CU_index).pai, cuhr (CU_index).pfa, cuhr (CU_index).inhib, cuhr (CU_index).xint, cuhr (CU_index).pib, (^OP.DUOP (fixed (OP_cur, 10)+1) & cuhr (CU_index).its_flag)); call ioa_$ioa_switch_nnl (iocbp, "^[port ^]^[internal ^]^[cache flush ^]", cuhr (CU_index).portf, cuhr (CU_index).internal, cuhr (CU_index).cache_flush); if substr (ext_hr.DU_OU.odd (CU_index), 19, 18) ^= "0"b then do; call ioa_$ioa_switch_nnl (iocbp, "^/OU ^[^12.3b ^12.3b^;^2s^4t^]^41x", lo_sw, ext_hr.DU_OU.even (CU_index), ext_hr.DU_OU.odd (CU_index)); call ioa_$ioa_switch_nnl (iocbp, "^[^/^7t^]RS-REG=^a ^[dtrgo ^]", (lo_sw & ll_sw), ltrim (rtrim (OP.code (fixed (du_ouhr (CU_index).rs || "0"b, 10) +1))), du_ouhr (CU_index).dtrgo, du_ouhr (CU_index).dtrgo); if ou_regs (CU_index).ou_inds ^= "0"b then do; call ioa_$ioa_switch_nnl (iocbp, "^[zero ^]^[sign ^]^[carry ^]^[ovfl ^]^[eovfl ^]^[eufl ^]^[oflm ^]^[hex ^]", du_ouhr (CU_index).ir_reg.zero_, du_ouhr (CU_index).ir_reg.sign_, du_ouhr (CU_index).ir_reg.carry_, du_ouhr (CU_index).ir_reg.ovfl_, du_ouhr (CU_index).ir_reg.eovfl_, du_ouhr (CU_index).ir_reg.eufl_, du_ouhr (CU_index).ir_reg.oflm_, du_ouhr (CU_index).ir_reg.hex_); end; end; if cuhr.op_code (CU_index) = XED then XED_flag = "1"b; if cuhr.op_code (CU_index) = XEC then XEC_flag = "1"b; if cuhr.pfa (CU_index) then return; if (cuhr.pia (CU_index) & ^(apuhr1.piapgbsy (AU_index) | apuhr1.piaoosb (AU_index))) then go to display_du; if au_synched = "1"b then if ext_hr.AU1.even (AU_index) ^= "0"b then do; display_apu: call aur; AU_index = AU_index +1; if au_cycle_done = "1"b then go to display_du; goto display_apu; /* keep going till APU cycle finished */ end; display_du: if OP.DUOP (fixed (OP_cur, 10)+1) & ^cuhr.pia (CU_index) then call dur; return; end; aur: proc; if AU_index > a_nregs then go to AU_DONE; if ext_hr.AU1.even (AU_index) = "0"b then return; SDW_print = " "; au_cycle_done = "0"b; if substr (ext_hr.AU1.even (AU_index), 16, 10) = "0"b then go to AU_DONE; /* not an APU cycle */ if cuhr.op_code (CU_index) ^= apuhr2.opcode (AU_index) then go to AU_DONE; if (cuhr.tag (CU_index) = "03"b3 | cuhr.tag (CU_index) = "07"b3) | (apuhr2.TAG (AU_index) = "03"b3 | apuhr2.TAG (AU_index) = "07"b3) then do; AU_DONE: au_cycle_done = "1"b; return; end; if apuhr1.fap (AU_index) = "1"b | apuhr1.fanp (AU_index) = "1"b then au_cycle_done = "1"b; if apuhr1.sdwmf (AU_index) then do; call ioa_$rsnnl ("^1a", temp_char1, 1, LEVEL (fixed (apuhr1.sdwlvl (AU_index), 2))); call ioa_$rsnnl ("^2o", temp_char2, 2, fixed (substr (apuhr1.esn (AU_index), 12, 4), 4)); SDW_print = ltrim (rtrim (temp_char1)) || ltrim (rtrim (temp_char2)); end; PTW_print = " "; if apuhr1.ptwmf (AU_index) then do; call ioa_$rsnnl ("^1a", temp_char1, 1, LEVEL (fixed (apuhr1.ptwlvl (AU_index), 2))); call ioa_$rsnnl ("^2o", temp_char2, 2, fixed (apuhr1.ptwaddr (AU_index), 4)); PTW_print = ltrim (rtrim (temp_char1)) || ltrim (rtrim (temp_char2)); end; if apuhr2.opcode (AU_index) = "0"b then do; /* ^trust au2 so.. */ pr_auop = "0"b; pr_autag = "0"b; au2 = "0"b; go to no_au2; end; pr_auop = "1"b; /* assume display of opcode */ AUOP = apuhr2.opcode (AU_index); AUOP_PR = rtrim (OP.code (fixed (AUOP, 10)+1)); foo = length (AUOP_PR); /* do same thing as we did for CU */ foo = 5 -foo; OP_pad = PAD (foo); AUOP_PR = OP_pad || AUOP_PR; if AUOP_PR = OP_print then pr_auop = "0"b; pr_autag = "1"b; AUTAG = fixed (apuhr2.TAG (AU_index), 10)+1; AUTAG_PR = rtrim (TAG.code (AUTAG)); foo = length (AUTAG_PR); foo = 3 - foo; TAG_pad = PAD (foo); AUTAG_PR = TAG_pad || AUTAG_PR; if AUTAG_PR = TAG_print then pr_autag = "0"b; call ioa_$rsnnl ("^6o", tpr_ca, 6, fixed (apuhr2.CA (AU_index), 18)); TPR_CA_PR = "[" || ltrim (rtrim (tpr_ca)) || "]"; foo = length (TPR_CA_PR); foo = 8 - foo; OP_pad = PAD (foo); TPR_CA_PR = OP_pad || TPR_CA_PR; au2 = "1"b; no_au2: ausegno = fixed (apuhr1.esn (AU_index), 15); if ausegno = cusegno then AUSEG_pr = "0"b; else AUSEG_pr = "1"b; call ioa_$ioa_switch_nnl (iocbp, "^/AU ^[^12.3b ^12.3b^;^2s^5t^]^[^5o^;^s^5x^] ^[^8a^;^s^8x^] ^[^5a^;^s^5x^] ^[^3a^;^s^3x^]^3x^8o r^1o ", lo_sw, ext_hr.AU1.even (AU_index), ext_hr.AU1.odd (AU_index), AUSEG_pr, ausegno, au2, TPR_CA_PR, pr_auop, AUOP_PR, pr_autag, AUTAG_PR, fixed (apuhr1.finadd (AU_index), 25), fixed (apuhr1.trr (AU_index), 3)); call ioa_$ioa_switch_nnl (iocbp, "^[fdsptw ^]^[mdsptw ^]^[fsdw ^]^[fptw ^]^[fptw2 ^]^[mptw ^]", apuhr1 (AU_index).fdsptw, apuhr1 (AU_index).mdsptw, apuhr1 (AU_index).fsdwp, apuhr1 (AU_index).fptw, apuhr1 (AU_index).fptw2, apuhr1 (AU_index).mptw); call ioa_$ioa_switch_nnl (iocbp, "^[^/^7t^]^[fanp ^]^[fap ^]^[sdwm (^a) ^]^[ptwm (^a) ^]^[flt ^]^[flthld ^]^[cache ^]", (lo_sw & ll_sw), apuhr1 (AU_index).fanp, apuhr1 (AU_index).fap, apuhr1 (AU_index).sdwmf, ltrim (rtrim (SDW_print)), apuhr1 (AU_index).ptwmf, ltrim (rtrim (PTW_print)), apuhr1 (AU_index).flt, apuhr1 (AU_index).flthld, apuhr1 (AU_index).cache_used); call ioa_$ioa_switch_nnl (iocbp, "^[piapgbsy ^]^[piaoosb ^]^[*SDWAM-ERR* ^]^[*PTWAM-ERR* ^]", apuhr1 (AU_index).piapgbsy, apuhr1 (AU_index).piaoosb, apuhr1 (AU_index).sdwerr, apuhr1 (AU_index).ptwerr); if au_cycle_done = "1"b then if apuhr1.finadd (AU_index) ^= cuhr.ca_value (CU_index) then do; /* allow for ind cycles */ if substr (apuhr1.finadd (AU_index), 16, 9) = substr (cuhr.ca_value (CU_index), 16, 9) then if cuhr.its_flag (CU_index) then return; if substr (apuhr1.finadd (AU_index), 16, 9) = substr (cuhr.ca_value (CU_index -1), 16, 9) then return; if substr (apuhr1.finadd (AU_index), 16, 9) = substr (cuhr.ca_value (CU_index -2), 16, 9) then return; call ioa_$ioa_switch_nnl (iocbp, "^/*****Final Address Mismatch CU <=> AU: CU = ^8o :: AU = ^8o*****", cuhr.ca_value (CU_index), apuhr1.finadd (AU_index)); end; return; end; dur: proc; if ext_hr.DU_OU.even (CU_index) = "0"b then return; /* no DU entry */ if du_ouhr.du_word (CU_index) then DU_mode = "w"; else if du_ouhr.nine (CU_index) then DU_mode = "9"; else if du_ouhr.six (CU_index) then DU_mode = "6"; else if du_ouhr.four (CU_index) then DU_mode = "4"; else if du_ouhr.du_bit (CU_index) then DU_mode = "b"; else DU_mode = "?"; call ioa_$ioa_switch_nnl (iocbp, "^/DU ^[^12.3b ^12.3b^;^2s^4t^]^37x ^1a ", lo_sw, ext_hr.DU_OU.even (CU_index), ext_hr.DU_OU.odd (CU_index), DU_mode); call ioa_$ioa_switch_nnl (iocbp, "^[d1a ^]^[d2a ^]^[anstr ^]^[lrw1 ^]^[lrw2 ^]", ^du_ouhr (CU_index).fanld1, ^du_ouhr (CU_index).fanld2, ^du_ouhr (CU_index).fanstr, ^du_ouhr (CU_index).fldwrt1, ^du_ouhr (CU_index).fldwrt2); call ioa_$ioa_switch_nnl (iocbp, "^[d1n ^]^[d2n ^]^[ndsqflg ^]^[dud ^]^[gstr ^]", ^du_ouhr (CU_index).fnld1, ^du_ouhr (CU_index).fnld2, du_ouhr (CU_index).endseqf, ^du_ouhr.fdud (CU_index), ^du_ouhr.fgstr (CU_index)); call ioa_$ioa_switch_nnl (iocbp, "^[ndseq ^]^[sp1 ^]^[sp2 ^]^[sp3 ^]^[pop ^]^[addgC ^]", ^du_ouhr (CU_index).endseq, du_ouhr (CU_index).ptr1, du_ouhr (CU_index).ptr2, du_ouhr (CU_index).ptr3, du_ouhr (CU_index).fpop, ^du_ouhr (CU_index).fgeac); call ioa_$ioa_switch_nnl (iocbp, "^[addgE ^]^[addgF ^]^[addgH ^]^[ldptr1 ^]^[swdseq ^]", ^du_ouhr (CU_index).fgeae, ^du_ouhr (CU_index).fgeaf, ^du_ouhr (CU_index).fgeah, ^du_ouhr (CU_index).fgldp1, ^du_ouhr (CU_index).fsweq); call ioa_$ioa_switch_nnl (iocbp, "^[chrcyc ^]^[dfirst ^]^[exh ^]^[addcyc ^]^[intrptd ^]", ^du_ouhr (CU_index).fgch, du_ouhr (CU_index).dfrst, du_ouhr (CU_index).exh, ^du_ouhr (CU_index).fgadd, du_ouhr (CU_index).intrptd); call ioa_$ioa_switch_nnl (iocbp, "^[ldptr2 ^]^[gemC ^]^[btdgA ^]^[shftgt ^]", ^du_ouhr (CU_index).dcode.gldp2, du_ouhr (CU_index).dcode.gemc, du_ouhr (CU_index).dcode.gbda, du_ouhr (CU_index).dcode.gsp5); end; /* end dur */ %page; no_thread: entry (hr_data_ptr, a_iocbp, nregs, switches); code = 0; call setup; if code ^= 0 then return; if do_du then do_ou = "1"b; if ^expand_sw then do; if (do_cu | do_ou) then do; call ioa_$ioa_switch (iocbp, "^/^[CU-FLAGS OPCODE ADDRESS PT^]^[ ^]^[ DU REGS OU-IC RS IND^]^[ OU-IC^]", do_cu, ^do_cu, do_ou, ^do_ou); do i = a_nregs to 1 by - 1; call ioa_$ioa_switch (iocbp, "^2d ^[^6.3b ^6.3b ^8.3b ^4.3b^;^4s^]^[^2x^6.3b^;^s^]^[ ^12.3b ^6.3b ^3.3b ^3.3b^]", i, do_cu, cu_regs (i).cu_flags, cu_regs (i).cu_op, cu_regs (i).cu_addr, cu_regs (i).cu_pt_flags, ^do_ou, ou_regs (i).ou_ic, do_ou, ou_regs (i).du_regs, ou_regs (i).ou_ic, ou_regs (i).ou_rs, ou_regs (i).ou_inds); end; end; if do_au then do; call ioa_$ioa_switch (iocbp, "^/^3x^10tAPU#1 REGISTERS^40tAPU#2 REGISTERS"); do i = a_nregs to 1 by -1; call ioa_$ioa_switch (iocbp, "^2d ^5.3b ^4.3b ^3.3b ^.1b ^8.3b ^.3b ^3.3b^7x^6.3b ^6.3b", i, ap1_segno (i), ap1_flags1 (i), "0"b || ap1_flags2 (i), ap1_flt (i), ap1_finadd (i), ap1_trr (i), ap1_flags3 (i), ap2_ca (i), ap2_op (i)); end; end; return; end; if expand_sw then do; if do_cu then do; call ioa_$ioa_switch_nnl (iocbp, "^2/EXPANDED CU REGS^/^5tOU-IC^11tOP-CODE^23tADDRESS PC FLAGS"); do i = a_nregs to 1 by -1; call ioa_$ioa_switch_nnl (iocbp, "^/^2d ^6o^10t^10a^22t^8o ^2o ", i, fixed (du_ouhr.ict (i), 18), ltrim (rtrim (OP.code (fixed (cuhr.op_code (i), 10) +1)) || " " || ltrim (rtrim (TAG.code (fixed (cuhr.tag (i), 10) +1)))), fixed (cuhr.ca_value (i), 24), 2 * fixed (cuhr.pcmd (i), 3)); call ioa_$ioa_switch_nnl (iocbp, "^[pia ^]^[poa ^]^[riw ^]^[siw ^]^[pot ^]^[pon ^]", cuhr (i).pia, cuhr (i).poa, cuhr (i).riw, cuhr (i).siw, cuhr (i).pot, cuhr (i).pon); call ioa_$ioa_switch_nnl (iocbp, "^[raw ^]^[saw ^]^[inf ^]^[xde ^]^[xdo ^]^[ic ^]^[rpts ^]", cuhr (i).raw, cuhr (i).saw, cuhr (i).pia, cuhr (i).xde, cuhr (i).xdo, cuhr (i).ic, cuhr (i).rpts); call ioa_$ioa_switch_nnl (iocbp, "^[pai ^]^[pfa ^]^[inh ^]^[xint ^]^[pib ^]^[its ^]", cuhr (i).pai, cuhr (i).pfa, cuhr (i).inhib, cuhr (i).xint, cuhr (i).pib, (substr (cuhr (i).op_code, 10, 1) = "0"b & cuhr (i).its_flag)); call ioa_$ioa_switch_nnl (iocbp, "^[port ^]^[internal ^]^[cache flush ^]", cuhr (i).portf, cuhr (i).internal, cuhr (i).cache_flush); end; end; if do_au then do; call ioa_$ioa_switch_nnl (iocbp, "^2/EXPANDED APU REGS^/ SEGNO OFFSET INSTR FINAL ADDR FLAGS"); do i = a_nregs to 1 by -1; SDW_print = " "; if apuhr1.sdwmf (i) then do; call ioa_$rsnnl ("^1a", temp_char1, 1, LEVEL (fixed (apuhr1.sdwlvl (i), 2))); call ioa_$rsnnl ("^2o", temp_char2, 2, fixed (substr (apuhr1.esn (i), 12, 4), 4)); SDW_print = ltrim (rtrim (temp_char1)) || ltrim (rtrim (temp_char2)); end; PTW_print = " "; if apuhr1.ptwmf (i) then do; call ioa_$rsnnl ("^1a", temp_char1, 1, LEVEL (fixed (apuhr1.ptwlvl (i), 2))); call ioa_$rsnnl ("^2o", temp_char2, 2, fixed (apuhr1.ptwaddr (i), 4)); PTW_print = ltrim (rtrim (temp_char1)) || ltrim (rtrim (temp_char2)); end; call ioa_$ioa_switch_nnl (iocbp, "^/^2d ^5.3b ^6o ^10a ^8o ", i, apuhr1.esn (i), apuhr2.CA (i), ltrim (rtrim (OP.code (fixed (apuhr2.opcode (i), 10) +1)) || " " || ltrim (rtrim (TAG.code (fixed (apuhr2.TAG (i), 10) +1)))), fixed (apuhr1.finadd (i), 24)); call ioa_$ioa_switch_nnl (iocbp, "^[fdsptw ^]^[mdsptw ^]^[fsdw ^]^[fptw ^]^[fptw2 ^]^[mptw ^]", apuhr1 (i).fdsptw, apuhr1 (i).mdsptw, apuhr1 (i).fsdwp, apuhr1 (i).fptw, apuhr1 (i).fptw2, apuhr1 (i).mptw); call ioa_$ioa_switch_nnl (iocbp, "^[fanp ^]^[fap ^]^[sdwm (^a) ^]^[ptwm (^a) ^]^[flt ^]^[flthld ^]^[cache ^]", apuhr1 (i).fanp, apuhr1 (i).fap, apuhr1 (i).sdwmf, ltrim (rtrim (SDW_print)), apuhr1 (i).ptwmf, ltrim (rtrim (PTW_print)), apuhr1 (i).flt, apuhr1 (i).flthld, apuhr1 (i).cache_used); call ioa_$ioa_switch_nnl (iocbp, "^[piapgbsy ^]^[piaoosb ^]^[*SDWAM-ERR* ^]^[*PTWAM-ERR* ^]", apuhr1 (i).piapgbsy, apuhr1 (i).piaoosb, apuhr1 (i).sdwerr, apuhr1 (i).ptwerr); end; end; if do_ou then do; call ioa_$ioa_switch_nnl (iocbp, "^2/EXPANDED DU/OU REGS^/^5tOU-IC RS-REG ^15tDU/OU-INDS"); do i = a_nregs to 1 by -1; call ioa_$ioa_switch_nnl (iocbp, "^/^2d ^6o^10t^a^18t^[zero ^]^[sign ^]^[carry ^]^[ovfl ^]^[eovfl ^]^[eufl ^]^[oflm ^]^[hex ^]^[dtrgo ^]", i, fixed (du_ouhr.ict (i), 18), ltrim (rtrim (OP.code (fixed (du_ouhr (i).rs || "0"b, 10) +1))), du_ouhr (i).ir_reg.zero_, du_ouhr (i).ir_reg.sign_, du_ouhr (i).ir_reg.carry_, du_ouhr (i).ir_reg.ovfl_, du_ouhr (i).ir_reg.eovfl_, du_ouhr (i).ir_reg.eufl_, du_ouhr (i).ir_reg.oflm_, du_ouhr (i).ir_reg.hex_, du_ouhr (i).dtrgo); if substr (cuhr.op_code (i), 10, 1) & ^cuhr.pia (i) then do; if du_ouhr.du_word (CU_index) then DU_mode = "w"; else if du_ouhr.nine (CU_index) then DU_mode = "9"; else if du_ouhr.six (CU_index) then DU_mode = "6"; else if du_ouhr.four (CU_index) then DU_mode = "4"; else if du_ouhr.du_bit (CU_index) then DU_mode = "b"; else DU_mode = "?"; call ioa_$ioa_switch_nnl (iocbp, "^[d1a ^]^[d2a ^]^[anstr ^]^[lrw1 ^]^[lrw2 ^]", ^du_ouhr (CU_index).fanld1, ^du_ouhr (CU_index).fanld2, ^du_ouhr (CU_index).fanstr, ^du_ouhr (CU_index).fldwrt1, ^du_ouhr (CU_index).fldwrt2); call ioa_$ioa_switch_nnl (iocbp, "^[d1n ^]^[d2n ^]^[ndsqflg ^]^[dud ^]^[gstr ^]", ^du_ouhr (CU_index).fnld1, ^du_ouhr (CU_index).fnld2, du_ouhr (CU_index).endseqf, ^du_ouhr.fdud (CU_index), ^du_ouhr.fgstr (CU_index)); call ioa_$ioa_switch_nnl (iocbp, "^[ndseq ^]^[sp1 ^]^[sp2 ^]^[sp3 ^]^[pop ^]^[addgC ^]", ^du_ouhr (CU_index).endseq, du_ouhr (CU_index).ptr1, du_ouhr (CU_index).ptr2, du_ouhr (CU_index).ptr3, du_ouhr (CU_index).fpop, ^du_ouhr (CU_index).fgeac); call ioa_$ioa_switch_nnl (iocbp, "^[addgE ^]^[addgF ^]^[addgH ^]^[ldptr1 ^]^[swdseq ^]", ^du_ouhr (CU_index).fgeae, ^du_ouhr (CU_index).fgeaf, ^du_ouhr (CU_index).fgeah, ^du_ouhr (CU_index).fgldp1, ^du_ouhr (CU_index).fsweq); call ioa_$ioa_switch_nnl (iocbp, "^[chrcyc ^]^[dfirst ^]^[exh ^]^[addcyc ^]^[intrptd ^]", ^du_ouhr (CU_index).fgch, du_ouhr (CU_index).dfrst, du_ouhr (CU_index).exh, ^du_ouhr (CU_index).fgadd, du_ouhr (CU_index).intrptd); call ioa_$ioa_switch_nnl (iocbp, "^[ldptr2 ^]^[gemC ^]^[btdgA ^]^[shftgt ^]", ^du_ouhr (CU_index).dcode.gldp2, du_ouhr (CU_index).dcode.gemc, du_ouhr (CU_index).dcode.gbda, du_ouhr (CU_index).dcode.gsp5); end; end; end; end; return; %page; setup: proc; /* *********************************************************** * check iocbp and long switch, set control accordingly * *********************************************************** */ if a_iocbp = null then /* called to use default io switch */ iocbp = iox_$user_output; else iocbp = a_iocbp; if hr_data_ptr = null then do; /* check validity of ptr */ call ioa_$ioa_switch (iocbp, "^/History Register Pointer is Null"); code = -1; return; /* must be a bad call */ end; a_nregs = nregs; if a_nregs = 64 then do; /* set up proper offsets to hr data */ cu_offset = 128; au_offset2 = 256; au_offset1 = 384; a_nregs = 16; /* we currently only save 16 in bce toehold */ end; du_ouhrp = addrel (hr_data_ptr, du_ou_offset); /* set pointer to Ops Unit data */ cuhrp = addrel (hr_data_ptr, cu_offset); /* set pointer to Control Unit data */ aphrp2 = addrel (hr_data_ptr, au_offset2); /* set pointer to DU data */ aphrp1 = addrel (hr_data_ptr, au_offset1); /* set pointer to App Unit data */ OP_ptr = addr (OP_table); /* set pointer to opcode table */ TAG_ptr = addr (TAG_table); /* set pointer to tag table */ /* *********************************************************************** * If history registers were not saved, fim will zero the block out. * * So we need to see if the block is valid by checking for zeroes. * *********************************************************************** */ if hr_data_ptr -> hr_block = "0"b then do; call ioa_$ioa_switch (iocbp, "^/History Register Buffer is Empty"); code = -1; return; end; /* get terminal line length */ ll_sw = get_line_length_$switch (null (), (0)) <= 80; return; end setup; %page; /* This subroutine is used to get the AU hregs in synch with the CU hregs */ synch_auhr: proc; do AU_index = 1 to a_nregs while (au_synched = "0"b); if apuhr2.opcode (AU_index) = cuhr.op_code (CU_index) then if apuhr1.finadd (AU_index) = cuhr.ca_value (CU_index) then if ext_hr.AU1.even (AU_index) ^= "0"b then if (apuhr2.TAG (AU_index) ^= "03"b3 | apuhr2.TAG (AU_index) ^= "07"b3) then au_synched = "1"b; end; if au_synched = "0"b then AU_index = a_nregs +1; else AU_index = AU_index -1; return; end synch_auhr; %page; %include history_regs_dps8; %page; %include opcode_tag_table; end hran_dps8_;  hran_l68_.pl1 02/13/85 0937.7r w 02/13/85 0857.3 336087 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Coded by Rich Coppola August 1980, for DPS8 support of history registers. This routine was taken, essentially intact, from the old hranl_. Modified August 83 by B. Braun to change the long format (when lo_sw is on) to fit neatly on a 80 char screen. Modified 01 Nov 83 by B. Braun to correct OU ioa_ string for bos_no_thread entry. Modified 01 Oct 84 by B. Braun to correct display of hregs from the dump header as per K. Loepere change. Modified 19 Nov 84 by B. Braun as per Alf Burnham changes (phx17889): 1: Cure the AU CU synchronization problem with non-paged segments. 2:Cure the AU runoff beyond index 16 when no fap or fanp in last cycle. 3:Stop displaying an AU entry on a conditional transfer not taken. 4:Correct erroneous display of cu store cycle */ hran_l68_: proc; /* PARAMETERS */ dcl a_iocbp ptr; dcl lo_sw bit (1); dcl switches bit (5); /* tell what to print and how */ /* must be in this order */ /* expand_sw, ou, cu, au, du */ /* EXTERNAL DATA */ dcl get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin); dcl ioa_ entry options (variable), ioa_$ioa_switch options (variable), ioa_$ioa_switch_nnl entry options (variable), ioa_$rsnnl entry options (variable), iox_$user_output ptr ext; /* default io switch */ dcl 1 a_switches based (addr (switches)), (2 expand_sw bit (1), 2 do_ou bit (1), 2 do_cu bit (1), 2 do_au bit (1), 2 do_du bit (1)) unal; dcl 1 OU_ (16) based (ouhrp), 2 even bit (36), 2 odd bit (36); dcl 1 CU_ (16) based (cuhrp), 2 even bit (36), 2 odd bit (36); dcl 1 DU_ (16) based (duhrp), 2 even bit (36), 2 odd bit (36); dcl 1 AU_ (16) based (aphrp), 2 even bit (36), 2 odd bit (36); /* AUTOMATIC STORAGE */ dcl AU_index fixed, /* AU data index */ AU_ptr ptr, /* pointer to AU data */ AU_synch fixed, /* AU index for synch */ CU_index fixed, /* index into CU data */ CU_ptr ptr, /* pointer to CU data */ CU_synch fixed, /* index value at which CU & OU synchronize */ CY_print char (1), /* cycle type for output */ DU_index fixed, /* DU entry index */ DU_mode char (1), /* DU execution mode symbol */ EXP_DU_mode char (4), DU_ptr ptr, /* pointer to DU data */ IC_cur fixed (18) init (0), /* current IC value for CU entries */ IC_flag bit (1), /* IC print control flag */ IC_next fixed (18) init (0), /* next =C value for CU lines */ IC_print char (7), /* printed IC value */ IC_synch fixed (18), /* IC tracker value at synchronization */ IC_value fixed (18), /* IC value for output */ NOP_flag bit (1) init ("0"b), /* flag for NOP cycles */ OP_cur bit (10) init ((10)"0"b), /* current opcode for CU lines */ OP_print char (5), /* opcode string for printing */ OU_ptr ptr, /* pointer to OU data */ OU_index fixed bin, /* index into OU data */ OU_synch fixed init (0), /* index value at which OU & CU synchronize */ PTW_print char (2), /* PTWAMR number for printing */ SDW_print char (2), /* SDWAMR number for printing */ SEG_print char (5), /* segment number for printing */ TAG_cur fixed, /* current TAG table index */ TAG_print char (4), /* TAG string for printing */ XD1_flag bit (1) init ("0"b), /* flag for 1st of XED pair */ XD2_flag bit (1) init ("0"b), /* flag for 2nd of XED pair */ XEC_flag bit (1) init ("0"b), /* XEC flag */ XED_flag bit (1) init ("0"b), /* XED flag */ count_diff fixed, /* repeat/repull count difference */ ll_sw bit(1), null builtin, iocbp ptr, /* output switch name */ fetch_count fixed init (0), /* fetch cycle count */ index fixed, /* general loop index */ pull_count fixed init (0), /* index into instruction pull table */ pull_index fixed; /* index into instruction pull table */ dcl (i, j) fixed bin; dcl (a_do_du, a_do_cu) bit (1); dcl 1 hr, /* copy of HR data (corrected) */ 2 OU (16), 3 even bit (36), 3 odd bit (36), 2 CU (16), 3 even bit (36), 3 odd bit (36), 2 DU (16), 3 even bit (36), 3 odd bit (36), 2 AU (16), 3 even bit (36), 3 odd bit (36); dcl 1 a_ouhra (16) like ouhra; /* auto storage for OU hregs */ dcl 1 a_cuhra (16) like cuhra; /* auto storage for CU hregs */ dcl 1 a_duhra (16) like duhra; /* auto storage for DU hregs */ dcl 1 a_apuhra (16) like apuhra; /* auto storage for AU hregs */ dcl au_sync_mod_value(16) fixed; /* table to hold mod values used in AU CU synchronization */ dcl 1 pull_table (16), /* instruction pull table */ 2 index fixed unal init ((16)0), 2 pt_addr bit (18) unal init ((16) (18)"0"b); dcl repeat_count fixed init (0), /* OU instruction repeat count */ repull_count fixed, /* instruction repull count for loop checking */ synch_flag bit (1), /* synchronization flag */ tag_chain_flag bit (1); /* tag print control flag */ dcl hr_block bit (36*128) based; /* #of bits in the hr data block */ dcl code fixed bin (35); dcl from_bos bit (1) init ("0"b); %page; hranl_l68_bos: entry (hr_data_ptr, a_iocbp, lo_sw); from_bos = "1"b; go to START; hranl_l68_: entry (hr_data_ptr, a_iocbp, lo_sw); from_bos = "0"b; START: code = 0; call setup; if code ^= 0 then return; /* History regs are valid, print heading and initialize */ call ioa_$ioa_switch (iocbp, "L68 History Register Analysis"); call ioa_$ioa_switch (iocbp, "^/ HR^[^5-^;^24x^]c", lo_sw); call ioa_$ioa_switch_nnl (iocbp, "id##^[^8xhr contents^-^;^3x^]IC_____ opcd__ tag_ y seg#_ offset__ mc ^[^/^7tflags^;flags^/^]", lo_sw, (lo_sw & ll_sw)); /* Copy the data. There are cases where the data is inconsistent because of hardware timing delays and these inconsistencies must be removed before analysis can be done. */ OU = OU_; /* copy the entire structure */ CU = CU_; DU = DU_; AU = AU_; a_ouhra = ouhra; /* and do it again */ a_cuhra = cuhra; a_duhra = duhra; a_apuhra = apuhra; /* Build the table of mod values used in syncing AU to CU */ do AU_index = 1 to 16; if a_apuhra.fap (AU_index) then au_sync_mod_value (AU_index) = 1024; else au_sync_mod_value (AU_index) = 16; /* if not fap then could be non-paged segment. Assume so.*/ end; /* Fix up repeated values of IC Tracker. These occur because of differences in timing between the OU, which strobes the data, and the CU, which controls the value */ do OU_index = 2 to 16; /* from 2nd to last */ /* if IC Tracker value is the same, then ... */ if a_ouhra.ict (OU_index) = a_ouhra.ict (OU_index-1) then /* if all flags are _n_o_t the same, then ... (If IC Tracker _a_n_d all flags are the same, the OU is in multi-cycle or is repeating) */ if hr.OU.even (OU_index) ^= hr.OU.even (OU_index-1) then /* and if the op is _n_o_t LREG or SREG ... */ if a_ouhra.rp (OU_index) ^= LREG & a_ouhra.rp (OU_index) ^= SREG then /* add one to IC Tracker value */ a_ouhra.ict (OU_index) = bit (add (fixed (a_ouhra.ict (OU_index)), 1, 17, 0), 18); end; /* Construct an instruction pull table containing the CU_index and addr for all true instruction pulls . Also count all fetch cycles (including descriptor fetches and dummy fetches */ do CU_index = 1 to 16; /* look at all CU entries */ /* if the instruction fetch flag in port data is set, then ... */ if a_cuhra.ins_fetch (CU_index) then do; fetch_count = fetch_count+1; /* count a fetch cycle */ /* if the CU is preparing an instruction address _o_r taking a transfer ... */ if (a_cuhra.pia (CU_index) | a_cuhra.trgo (CU_index)) /* _a_n_d this is not the fault cycle ... */ & a_cuhra.nflt (CU_index) then do; pull_table.index (pull_count+1) = CU_index; /* save CU_index and ... */ /* computed address */ pull_table.pt_addr (pull_count+1) = a_cuhra.ca_value (CU_index); pull_count = pull_count+1; /* count an instruction pull */ end; end; end; /* Test instruction pull count. If zero, then ... Hypothesis 1 --- The CU will execute 16 (or more) cycles without an instruction pull only if one of the following conditions obtain ... 1) A long EIS instruction is being executed, 2) There is a very long indirect chain, 3) The CU is in repeat mode. Under this hypothesis, there may be at most four instructions appearing in the CU history register with the fault occuring in the last one. The last instruction pull has been overwritten and the fault occurs before or during the next pull. Thus all instructions appearing are in strictly sequential order and the IC Tracker value in OU17 (fault OU) is the value for CU17. */ if pull_count = 0 then do; IC_synch = fixed (a_ouhra.ict (16)); /* set IC synch point to last value */ OU_synch = 16; /* set OU synch index value */ HRG01C: do CU_synch = 16 to 2 by -1; /* search CU entries backwards */ /* for the fault opcode */ if a_cuhra.op_code (CU_synch) = a_ouhra.rp (16) then /* found it if OU-load or OU-store are set */ if a_cuhra.oul (CU_synch) | a_cuhra.ous (CU_synch) then goto HRG05C; end; goto HRG05C; /* if no match, must look further */ end; /* Pull count is non-zero. Find the first instruction pulled */ pull_table.index (pull_count+1) = 16; /* add fault cycle for table control */ do pull_index = 1 to pull_count; /* using all pull table entries */ do CU_index = pull_table.index (pull_index) to 16; /* scan all CU entries */ IC_synch = fixed (pull_table.pt_addr (pull_index), 18); /* tentative IC synch */ if ^a_cuhra.nflt (CU_index) then goto HRG02F; /* if this the fault cycle, the CU failed to complete the instruction pair during which it pulled the next pair. */ if OP.TR (fixed (a_cuhra.op_code (CU_index))+1) & a_cuhra.trgo (CU_index) then do; /* if this is a transfer taken, then ... */ CU_synch = CU_index+1; /* next CU entry is the one */ goto HRG05C; end; /* if IC is odd, then the next even instruction is from this pull */ if a_cuhra.ic (CU_index) then do CU_synch = CU_index to 16; if ^a_cuhra.ic (CU_synch) then goto HRG05C; end; end; /* loop on CU_index values */ HRG02A: end; /* loop on pull_index */ /* Hypothesis 2 --- The CU will fail to complete the current instruction pair ( or fail to reach the even instruction) if ... 1) The instruction pull is the last (or only) pull _a_n_d one of the condition of Hypothesis 1  applies during the execution of the current pair _a_n_d the CU faults on the instruction pull. or 2) The instruction pull is the only pull and is a "look ahead" pull _a_n_d execution of the  current pair leads to one of the conditions of Hypothesis 1. or 3) The processor is in a lock-up loop. The conditions for this hypothesis are the same as those to Hypothesis 1 with the exception of the single instruction pull allowed. The same procedure may be used. */ HRG02F: goto HRG01C; /* Check for a program loop by counting repulls of this instruction pair */ HRG05C: CU_index = CU_synch; /* save current CU_synch value */ /* if the opcode is LREG or SREG, then ... */ if a_cuhra.op_code (CU_index) = SREG | a_cuhra.op_code (CU_index) = LREG then do CU_synch = CU_index to 16 while /* search for last CU entry with opcode */ (a_cuhra.op_code (CU_synch) = a_cuhra.op_code (CU_index)); end; if CU_synch = 1 then goto HRG06; /* if this is the 1st CU entry ... */ if OP.OUOP (fixed (a_cuhra.op_code (CU_synch))) then /* if this is an OU OP ... */ do CU_index = CU_synch-1 to 1 by -1; /* search CU entries backwards for oldest entry matching this OU entry */ if CU_index > 1 then do; /* if this is _n_o_t the 1st CU entry ... */ /* and the opcode is the same as the prior entry ... */ if a_cuhra.op_code (CU_index) = a_cuhra.op_code (CU_synch) then /* and it is not lreg or sreg ... */ if a_cuhra.op_code (CU_index) ^= LREG & a_cuhra.op_code (CU_index) ^= SREG /* and the repeat flag is not set ... */ & ^a_cuhra.rpts (CU_index) /* or _n_o_t preparing instruction address, _n_o_t fetching or storing and indirect word, and _n_o_t pulling an instruction */ | (^a_cuhra.pia (CU_index) & ^a_cuhra.riw (CU_index) & ^a_cuhra.siw (CU_index) & ^a_cuhra.wi (CU_index)) then CU_synch = CU_index; end; end; goto HRG06; /* Hypothesis 5 --- Because the CU is "busier" than the OU, the OU will always contain at least as many occurences of an OU instruction as the CU. However, during "back-to-back" store operations, the IC Tracker may fall behand by a count. Most of these cases have already been covered by the ICT scan loop at HRG01F but the case of the double store will be covered here. */ HRG05H: if OU_synch = 0 then OU_synch = 16; do OU_index = 2 to 16; /* inspect all entries */ if a_ouhra.rp (OU_index) ^= LREG & a_ouhra.rp (OU_index) ^= SREG then if a_ouhra.ict (OU_index) = a_ouhra.ict (OU_index-1) then do; a_ouhra.ict (OU_index) = bit (add (fixed (a_ouhra.ict (OU_index)), 1, 35, 0), 18); if fixed (a_ouhra.ict (OU_index)) = IC_synch then goto HRG05C; end; end; /* Output CU entries up to CU_synch */ HRG06: IC_value = 0; /* initialize IC value for printout */ synch_flag = "0"b; /* reset synch flag */ tag_chain_flag, IC_flag = "0"b; /* reset control flags */ DU_index = fetch_count+1; /* initialize DU entry index */ AU_index = 0; /* turn off AU lines */ do AU_synch = 1 to 16 while /* synch AU to IC_synch */ ((mod (fixed (a_apuhra.finadd (AU_synch)), au_sync_mod_value(AU_synch)) ^= mod (IC_synch, au_sync_mod_value(AU_synch))) & (hr.AU.even (AU_synch) ^= "0"b)); end; do CU_index = 1 to CU_synch-1; if hr.CU.even (CU_index) ^= "0"b then call cur; end; /* Merge CU & OU entries up to fault cycle */ HRG08: IC_value = IC_synch; IC_flag = "1"b; OU_index = 0; synch_flag = "1"b; if CU_index = 16 then goto HRG09; do CU_index = CU_index to 15; if ^a_cuhra.nflt (CU_index) then go to do_fault_cycle; call cur; if OP.OUOP (fixed (OP_cur)+1) & (a_cuhra.oul (CU_index) | a_cuhra.ous (CU_index)) & ^a_cuhra.saw (CU_index) then do; if OU_synch = 0 then do OU_synch = 1 to 16 while (fixed (a_ouhra.ict (OU_synch), 18) ^= IC_value); end; if OU_synch = 17 then /* no synch found */ OU_synch = 0; /* reset for next time */ else if OU_index = 0 then OU_index = OU_synch; /* setup new found synch */ if OU_index > 0 & OU_index < 16 then do; /* within range */ call our; OU_index = OU_index + 1; end; end; end; /* Do the fault cycles */ do_fault_cycle: HRG09: call cur; call ioa_$ioa_switch (iocbp, "^/"); return; our: proc; if ^synch_flag then do; call ioa_$rsnnl ("^7o", IC_print, 7, fixed (a_ouhra.ict (OU_index))); IC_value = fixed (a_ouhra.ict (OU_index)); end; else IC_print = " "; if ^synch_flag then OP_print = OP.code (2*fixed (a_ouhra.rp (OU_index))+1); else OP_print = " "; call ioa_$ioa_switch_nnl (iocbp, "^/OU^2o^[ ^12.3b ^12.3b^;^2s^3x^]^7a ^6a^26x^[^/^7t^]", OU_index, lo_sw, hr.OU.even (OU_index), hr.OU.odd (OU_index), IC_print, OP_print, (lo_sw & ll_sw)); if a_ouhra.dir (OU_index) then if substr (a_cuhra.tag (OU_index), 1, 1) then call ioa_$ioa_switch_nnl (iocbp, "dl "); else call ioa_$ioa_switch_nnl (iocbp, "du "); call ioa_$ioa_switch_nnl (iocbp, "^[rb ^]^[rp ^]^[rs ^]^[in ^]^[os ^]", a_ouhra.opbf (OU_index), a_ouhra.frpf (OU_index), a_ouhra.srf (OU_index), a_ouhra.gin (OU_index), a_ouhra.gos (OU_index)); call ioa_$ioa_switch_nnl (iocbp, "^[d1 ^]^[d2 ^]^[oe ^]^[oa ^]^[om ^]^[on ^]", a_ouhra.gd1 (OU_index), a_ouhra.gd2 (OU_index), a_ouhra.goe (OU_index), a_ouhra.goa (OU_index), a_ouhra.gom (OU_index), a_ouhra.gon (OU_index)); call ioa_$ioa_switch_nnl (iocbp, "^[of ^]^[sd ^]^[-d ^]^[ar ^]^[qr ^]^[x0 ^]", a_ouhra.gof (OU_index), a_ouhra.fstr (OU_index), a_ouhra.dn (OU_index), ^a_ouhra.an (OU_index), ^a_ouhra.qn (OU_index), ^a_ouhra.x0n (OU_index)); call ioa_$ioa_switch_nnl (iocbp, "^[x1 ^]^[x2 ^]^[x3 ^]^[x4 ^]^[x5 ^]^[x6 ^]^[x7^]", ^a_ouhra.x1n (OU_index), ^a_ouhra.x2n (OU_index), ^a_ouhra.x3n (OU_index), ^a_ouhra.x4n (OU_index), ^a_ouhra.x5n (OU_index), ^a_ouhra.x6n (OU_index), ^a_ouhra.x7n (OU_index)); return; end; cur: proc; /* Determine if IC value is to be displayed */ if IC_cur ^= IC_value then goto cur02; /* if it has changed since last CU line ... */ /* or if we are repeating _o_r XEC'ing ... */ if a_cuhra.rpts (CU_index) | XEC_flag then goto cur03; cur02: if a_cuhra.op_code (CU_index) ^= OP_cur then /* if opcode has changed */ if IC_next ^= 0 then do; IC_value = IC_next; IC_flag = "1"b; IC_next = 0; end; else if IC_flag then IC_value = IC_value+1; IC_print = " "; /* reset IC print value */ if XED_flag then do; /* if XEDing ... */ if ^XD1_flag then do; /* if 1st of XED pair not been done ... */ XD1_flag = "1"b; /* we are about to do it */ goto cur03; end; if ^XD2_flag then do; /* if 2nd of XED pair has not been done ... */ if a_cuhra.op_code (CU_index) ^= OP_cur then XD2_flag = "1"b; /* we are about to do it */ goto cur03; end; if a_cuhra.op_code (CU_index) ^= OP_cur then XED_flag, XD1_flag, XD2_flag = "0"b; /* XED finished, reset all flags */ end; if IC_flag then do; if a_cuhra.ic (CU_index) then /* force to odd if ic flag is set */ IC_value = 2* divide (IC_value, 2, 18, 0)+1; else IC_value = 2* divide (IC_value, 2, 18, 0); /* else force even */ if IC_cur ^= IC_value then /* if it changed ... */ call ioa_$rsnnl ("^7o", IC_print, 7, IC_value); else IC_print = " "; IC_cur = IC_value; end; cur03: if a_cuhra.op_code (CU_index) = OP_cur & IC_print = " " then /* if neither IC nor opcode have changed ... */ OP_print = " """; /* this must be the same instruction */ else do; OP_cur = a_cuhra.op_code (CU_index); OP_print = OP.code (fixed (OP_cur)+1); end; cur04: if OP.DUOP (fixed (a_cuhra.op_code (CU_index))+1) /* if a decimal op ... */ | a_cuhra.op_code (CU_index) = STCA /* or STCA ... */ | a_cuhra.op_code (CU_index) = STCQ /* or STCQ ... */ | a_cuhra.op_code (CU_index) = STBA /* or STBA ... */ | a_cuhra.op_code (CU_index) = STBQ /* or STBQ ... */ | a_cuhra.rpts (CU_index) /* or its a repeat */ then do; /* print a blank TAG */ TAG_cur = 0; TAG_print = " "; end; else do; TAG_cur = fixed (a_cuhra.tag (CU_index))+1; TAG_print = TAG.code (TAG_cur); end; if TAG_cur > 0 then /* if its a true tag ... */ tag_chain_flag = TAG.chain (TAG_cur); /* set tag chain flag */ if ^a_cuhra.nflt (CU_index) then CY_print = "F"; else if ^a_cuhra.nxip (CU_index) then CY_print = "x"; else if a_cuhra.ins_fetch (CU_index) & (a_cuhra.pia (CU_index) | a_cuhra.wi (CU_index)) then do; CY_print = "i"; if a_cuhra.op_code (CU_index) ^= XED then IC_next = fixed (a_cuhra.ca_value (CU_index)); XED_flag, XD1_flag, XD2_flag = "0"b; /* reset XED flags for transfer */ end; else if a_cuhra.riw (CU_index) | a_cuhra.siw (CU_index) then CY_print = "n"; else if a_cuhra.cul (CU_index) then if a_cuhra.dir (CU_index) then CY_print = "d"; else CY_print = "o"; else if a_cuhra.ous (CU_index) then CY_print = "o"; else if OP.DUOP (fixed (OP_cur)+1) then CY_print = "e"; else if OP_cur = NOP | (OP.TR (fixed (OP_cur)+1) & ^a_cuhra.trgo (CU_index)) then do; CY_print = "*"; NOP_flag = "1"b; end; else if a_cuhra.oul (CU_index) | a_cuhra.ous (CU_index) then if a_cuhra.dir (CU_index) then CY_print = "d"; else CY_print = "o"; else CY_print = "?"; if AU_index = 0 & a_cuhra.ca_value (CU_index) = pull_table.pt_addr (1) then AU_index = AU_synch; if 0 hr_block = "0"b then do; call ioa_$ioa_switch (iocbp, "^/History Register Buffer is Empty"); code = -1; return; end; return; end setup; %page; %include opcode_tag_table; %page; %include history_regs_l68; end hran_l68_;  structure_find_.pl1 10/24/88 1629.2r w 10/24/88 1400.6 70326 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* Probably written by Sibert */ /* Modified 1984-10-04 BIM to admit all legal characters in structure names */ /* Modified 1984-10-04 BIM to add pathname and caller_ptr entrypoints */ structure_find_: procedure (); declare P_structure_name char (*) parameter; declare P_symbol_ptr pointer parameter; /* Output: pointer to runtime symbol node */ declare P_pathname char (*); declare P_code fixed bin (35) parameter; declare P_segment_ptr pointer; declare code fixed bin (35); declare pathname char (220); declare structure_name char (256) varying; declare outer_name char (64) varying; declare symbol_ptr pointer; declare 1 symbol aligned like runtime_symbol based (symbol_ptr); declare seg_ptr pointer; declare seg_bc fixed bin (24); declare comp_name char (32); declare error_table_$bad_arg fixed bin (35) external static; declare error_table_$noentry fixed bin (35) external static; declare hcs_$status_mins entry (ptr, fixed bin(2), fixed bin(24), fixed bin(35)); declare structure_lib_mgr_$next_segment entry (fixed bin, pointer, pointer, char (*), pointer, fixed bin); declare structure_lib_mgr_$get_segment entry (character (*), pointer, pointer, pointer, fixed binary, fixed binary (35)); declare structure_lib_mgr_$get_segment_ptr entry (pointer, fixed binary (24), character (*), pointer, pointer, fixed binary, fixed binary (35)); declare stu_$find_runtime_symbol entry (pointer, char (*), pointer, fixed bin (35)) returns (pointer); declare (addrel, before, null, rtrim, verify) builtin; /* */ structure_find_$search: entry (P_structure_name, P_symbol_ptr, P_code); structure_name = rtrim (P_structure_name); outer_name = before (structure_name, "."); call find_structure (); P_symbol_ptr = symbol_ptr; P_code = code; return; structure_find_$pathname: entry (P_pathname, P_structure_name, P_symbol_ptr, P_code); structure_name = rtrim (P_structure_name); outer_name = before (structure_name, "."); pathname = P_pathname; call find_structure$$pathname (); P_symbol_ptr = symbol_ptr; P_code = code; return; /**** This next clever device allows a program to find it's own symbol table and use it for structure display, or to use a bound in structure library. Eventually, this technology could be used to support -ref_dir lower down. */ structure_find_$pointer: entry (P_segment_ptr, P_structure_name, P_symbol_ptr, P_code); structure_name = rtrim (P_structure_name); outer_name = before (structure_name, "."); call find_component (P_segment_ptr, seg_ptr, seg_bc, comp_name); call find_structure$$pointer (seg_ptr, seg_bc, comp_name); P_symbol_ptr = symbol_ptr; P_code = code; return; MAIN_RETURN: P_code = code; return; /* */ find_component: procedure (seg_ptr, bound_seg_ptr, bound_seg_bc, comp_name); declare seg_ptr pointer; declare bound_seg_ptr pointer; declare bound_seg_bc fixed bin (24); declare comp_name char (32); declare component_info_$offset entry (pointer, fixed binary (18), pointer, fixed binary (35)); %include component_info; call hcs_$status_mins (seg_ptr, (0), bound_seg_bc, code); if code ^= 0 then return; bound_seg_ptr = setwordno (seg_ptr, 0); call component_info_$offset (bound_seg_ptr, wordno (seg_ptr), addr (ci), code); if code ^= 0 then /* not bound, mate */ comp_name = ""; else comp_name = ci.name; return; end find_component; find_structure: procedure (); declare seg_ptr pointer; declare header_ptr pointer; declare known_list_size fixed bin; declare known_list_ptr pointer; declare known_list (known_list_size) char (32) based (known_list_ptr) unaligned; declare seg_idx fixed bin; declare pathname_sw bit (1) aligned; declare ptr_sw bit (1) aligned; ptr_sw, pathname_sw = "0"b; go to COMMON; find_structure$$pathname: entry; ptr_sw = "0"b; pathname_sw = "1"b; go to COMMON; find_structure$$pointer: entry (P_seg_ptr, P_seg_bc, P_comp_name); declare P_seg_ptr pointer; declare P_seg_bc fixed bin (24); declare P_comp_name char (*); ptr_sw = "1"b; pathname_sw = "0"b; COMMON: symbol_ptr = null (); code = 0; if (structure_name = "") | (verify (structure_name, "$_.0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") ^= 0) then do; code = error_table_$bad_arg; return; end; if ^ptr_sw then seg_ptr = null (); seg_idx = 0; if pathname_sw | ptr_sw then do; if pathname_sw then call structure_lib_mgr_$get_segment (pathname, seg_ptr, header_ptr, known_list_ptr, known_list_size, code); else call structure_lib_mgr_$get_segment_ptr (P_seg_ptr, P_seg_bc, P_comp_name, header_ptr, known_list_ptr, known_list_size, code); if code = 0 then call search_segment (); if symbol_ptr = null () then code = error_table_$noentry; return; end; do while ((seg_idx = 0) | (seg_ptr ^= null ())); call structure_lib_mgr_$next_segment (seg_idx, seg_ptr, header_ptr, (""), known_list_ptr, known_list_size); if (seg_ptr ^= null ()) then do; call search_segment (); if (symbol_ptr ^= null ()) then return; end; end; code = error_table_$noentry; return; /* */ search_segment: procedure (); declare rootp pointer; declare idx fixed bin; symbol_ptr = null (); /* until we find it*/ if (header_ptr = null ()) then return; if (header_ptr -> std_symbol_header.identifier ^= "symbtree") then return; if (header_ptr -> std_symbol_header.area_pointer = ""b) then return; rootp = addrel (header_ptr, header_ptr -> std_symbol_header.area_pointer); if (rootp -> pl1_symbol_block.identifier ^= "pl1info") then return; if (rootp -> pl1_symbol_block.root = ""b) then return; rootp = addrel (header_ptr, rootp -> pl1_symbol_block.root); if (hbound (known_list, 1) = 0) then do; /* No list, so try for anything */ call search_block (rootp); return; end; do idx = 1 to hbound (known_list, 1); if (known_list (idx) = outer_name) then do; call search_block (rootp); return; end; end; /* Didn't find it */ symbol_ptr = null (); return; /* */ search_block: procedure (P_blockp); declare P_blockp pointer parameter; declare block_ptr pointer; declare block_offset bit (18) aligned; declare stu_code fixed bin (35); declare parentp pointer; symbol_ptr = stu_$find_runtime_symbol (P_blockp, (outer_name), parentp, stu_code); if (symbol_ptr ^= null ()) then /* Found a level 1 structure */ if (binary (symbol.type, 6) = structure_dtype) then if (symbol.level = "01"b3) then do; if (outer_name = structure_name) then return; symbol_ptr = stu_$find_runtime_symbol (P_blockp, (structure_name), parentp, stu_code); if (symbol_ptr ^= null ()) then return; end; /* Couldn't find it here, so try the sons (if any) */ block_ptr = P_blockp; do block_offset = (P_blockp -> runtime_block.son) repeat (block_ptr -> runtime_block.brother) while (block_offset ^= ""b); block_ptr = addrel (block_ptr, block_offset); call search_block (block_ptr); if (symbol_ptr ^= null ()) then return; /* Found it */ end; return; /* It's still null, and we've found nothing */ end search_block; end search_segment; end find_structure; %page; %include std_symbol_header; %page; %include pl1_symbol_block; %page; %include runtime_symbol; %page; %include std_descriptor_types; end structure_find_;  structure_lib_mgr_.pl1 10/24/88 1629.2r w 10/24/88 1400.6 156726 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ structure_lib_mgr_: procedure (); return; /* not an entrypoint */ /* Written 30 May 1983, W. Olin Sibert (from struct_seg_man_) */ /* Modified for mr10.2 to not use a search list at all. Instead the pathname is hardcoded in. B. Braun 09/15/83 */ /* Modified at some later time to use the search list after all. */ /* Modified 1984-10-03 BIM to make archive components work, remove search list setting (in favor of .search segment), and add get_segment_ptr entrypoint. */ /* * STRUCTURE_LIB_MGR_ (nee struct_seg_man_) * * This is the procedure used to locate the library segments for the * structure display facility in analyze_multics, and manage the * structure search list. The reason for the extra layer of * procedure being used here is to provide an easy interface to * get segment pointers, which are remembered in an array internal * to this program. The array is rebuilt whenever the search list * changes, and also if any error ever occurs accessing one of the * segments. * */ dcl P_seg_idx fixed bin parameter; dcl P_segp pointer parameter; dcl P_bit_count fixed bin (24); dcl P_comp_name char (*); dcl P_headerp pointer parameter; dcl P_pathname char (*) parameter; dcl P_known_list_ptr pointer; dcl P_known_list_size fixed bin; dcl P_code fixed bin (35) parameter; dcl code fixed bin (35); dcl last_change_idx fixed bin (71) internal static init (-137); /* used to decide whether search list has changed */ dcl change_idx_ptr pointer internal static init (null ()); dcl seg_info_ptr pointer internal static init (null ()); /* address of seg pointer array */ dcl alloc_seg_info_count fixed bin; dcl 1 seg_info based (seg_info_ptr), 2 count fixed bin, 2 max_count fixed bin, 2 array (alloc_seg_info_count refer (seg_info.count)) like seg_info_entry; dcl 1 seg_info_entry aligned based, 2 seg_ptr pointer, 2 header_ptr pointer, 2 time_compiled fixed bin (71), 2 pl1_root pointer, 2 known_list_ptr pointer, 2 known_list_size fixed bin, 2 pathname char (168) unaligned, 2 name char (32) unaligned; dcl 1 temp_seg_info aligned like seg_info_entry automatic; dcl com_err_ entry options (variable); dcl component_info_$name entry (pointer, char (*), pointer, fixed bin (35)); dcl expand_pathname_$component entry (character (*), character (*), character (*), character (*), fixed binary (35)); dcl get_system_free_area_ entry returns (pointer); dcl initiate_file_$component entry (character (*), character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35)); dcl object_info_$brief entry (pointer, fixed bin (24), pointer, fixed bin (35)); dcl pathname_$component entry (character (*), character (*), character (*)) returns(character (194)); dcl search_paths_$set entry (character (*), pointer, pointer, fixed binary (35)); dcl search_paths_$get entry (char (*), bit (36), char (*), pointer, pointer, fixed bin, pointer, fixed bin (35)); dcl stu_$find_runtime_symbol entry (pointer, char (*), pointer, fixed bin (35)) returns (pointer); dcl error_table_$oldobj fixed bin (35) external static; dcl error_table_$no_search_list fixed bin (35) external static; dcl error_table_$new_search_list fixed bin (35) external static; dcl error_table_$bad_segment fixed bin (35) external static; dcl error_table_$zero_length_seg fixed bin (35) external static; dcl WHOAMI char (32) internal static options (constant) init ("structure_lib_mgr_"); dcl SDL_LIST_NAME char (32) internal static options (constant) init ("structure"); dcl (cleanup, out_of_bounds, no_read_permission, not_in_read_bracket, seg_fault_error) condition; dcl (addr, codeptr, length, hbound, null, substr) builtin; %include access_mode_values; /* */ /* This entry returns information about the "next" segment in the search list. It assumes that the search list does not change between calls to this entrypoint, though if it does, the effect should be largely benign. The first call should initialize P_seg_idx to zero; subsequent calls will increment P_seg_idx, and a null pointer will be returned when there are no more segments to be had. */ structure_lib_mgr_$next_segment: entry (P_seg_idx, P_segp, P_headerp, P_pathname, P_known_list_ptr, P_known_list_size); P_segp = null (); /* Default values for initialization */ P_headerp = null (); P_pathname = ""; P_seg_idx = P_seg_idx + 1; /* get the next one, and return it */ if ^get_seg_info () then return; /* get the array */ if (P_seg_idx > seg_info.count) then return; /* all used up; just return */ P_segp = seg_info.seg_ptr (P_seg_idx); P_headerp = seg_info.header_ptr (P_seg_idx); P_pathname = seg_info.pathname (P_seg_idx); P_known_list_ptr = seg_info.known_list_ptr (P_seg_idx); P_known_list_size = seg_info.known_list_size (P_seg_idx); return; /* end of code for $next_segment */ /* */ /* This entrypoint gets relevant information about a specific segment */ structure_lib_mgr_$get_segment: entry (P_pathname, P_segp, P_headerp, P_known_list_ptr, P_known_list_size, P_code); if ^find_segment (P_pathname, addr (temp_seg_info), "0"b) then do; P_segp = null (); P_headerp = null (); P_known_list_ptr = null (); P_known_list_size = 0; P_code = code; return; end; P_segp = temp_seg_info.seg_ptr; P_headerp = temp_seg_info.header_ptr; P_known_list_ptr = temp_seg_info.known_list_ptr; P_known_list_size = temp_seg_info.known_list_size; P_code = 0; return; /**** This entrypoint takes a segment pointer, and does the object segment analysis. */ structure_lib_mgr_$get_segment_ptr: entry (P_segp, P_bit_count, P_comp_name, P_headerp, P_known_list_ptr, P_known_list_size, P_code); if ^find_segment$$analyze (P_segp, P_bit_count, P_comp_name, addr (temp_seg_info)) then do; P_headerp = null (); P_known_list_ptr = null (); P_known_list_size = 0; return; end; P_headerp = temp_seg_info.header_ptr; P_known_list_ptr = temp_seg_info.known_list_ptr; P_known_list_size = temp_seg_info.known_list_size; P_code = 0; return; /* */ get_seg_info: procedure () returns (bit (1) aligned); /* This procedure fills in the seg_info array whenever the search list changes. It returns a bit indicating whether it was successful at getting it. */ dcl idx fixed bin; dcl idx1 fixed bin; dcl next_seg_idx fixed bin; dcl original_num_paths fixed bin; dcl update_sw bit (1) aligned; dcl system_area_ptr pointer; dcl system_area area based (system_area_ptr); if ^search_list_changed () then return ("1"b); /* OK if it's still the same */ system_area_ptr = get_system_free_area_ (); sl_info_p = null (); /* prepare for cleanup handler */ on condition (cleanup) begin; if (sl_info_p ^= null ()) then free sl_info in (system_area); end; call search_paths_$get (SDL_LIST_NAME, sl_control_default, "", null (), addr(system_area), (1), sl_info_p, code); if code ^= 0 then do; call com_err_ (code, WHOAMI, "Cannot get ^a search list.", SDL_LIST_NAME); return ("0"b); end; if (sl_info.num_paths = 0) then do; /* nothing there already */ call com_err_ (0, WHOAMI, "The ^a search list is empty.", SDL_LIST_NAME); goto GET_SEG_INFO_RETURNS; end; if (seg_info_ptr ^= null ()) then do; /* free old one */ free seg_info in (system_area); seg_info_ptr = null (); end; original_num_paths = sl_info.num_paths; /* Used to reset so extents will be correct when freeing */ alloc_seg_info_count = sl_info.num_paths; allocate seg_info in (system_area) set (seg_info_ptr); seg_info.max_count = alloc_seg_info_count; seg_info.count = 0; next_seg_idx = 1; /* Index of next entry to fill in */ update_sw = "0"b; /* Whether we need to re-set the list afterwards */ do idx = 1 to sl_info.num_paths; /* loop through and initiate all the search paths */ if (sl_info.paths (idx).type ^= ABSOLUTE_PATH) then do; call com_err_ (0, WHOAMI, "Removing invalid search path ^a.", sl_info.paths (idx).pathname); update_sw = "1"b; goto NEXT_SEARCH_PATH; end; if ^find_segment (sl_info.paths (idx).pathname, addr (seg_info.array (next_seg_idx)), "1"b) then do; update_sw = "1"b; /* Must update */ goto NEXT_SEARCH_PATH; /* We've already printed a message */ end; do idx1 = 1 to seg_info.count; /* Check for duplications now */ if (seg_info.header_ptr (idx1) = seg_info.header_ptr (next_seg_idx)) then do; call com_err_ (0, WHOAMI, "^a appears multiply in the ^a search list.^/^3xExtra instances will be removed.", seg_info.pathname (idx1), SDL_LIST_NAME); update_sw = "1"b; goto NEXT_SEARCH_PATH; /* Only one duplication can ever occur at a time, */ end; /* since others would have been detected already */ end; seg_info.count = next_seg_idx; next_seg_idx = next_seg_idx + 1; /* Go on to the next slot */ if (sl_info.paths (idx).pathname ^= seg_info.pathname (seg_info.count)) then update_sw = "1"b; /* update to include the suffix */ NEXT_SEARCH_PATH: end; if update_sw then do; /* Update back into the search list */ do idx = 1 to seg_info.count; sl_info.paths (idx).type = ABSOLUTE_PATH; sl_info.paths (idx).pathname = seg_info.pathname (idx); sl_info.paths (idx).code = 0; end; sl_info.num_paths = seg_info.count; call search_paths_$set (SDL_LIST_NAME, (null ()), sl_info_p, (0)); if (sl_info.num_paths = 0) then call com_err_ (0, WHOAMI, "The ^a search list is empty.", SDL_LIST_NAME); end; last_change_idx = sl_info.change_index; change_idx_ptr = sl_info.change_index_p; GET_SEG_INFO_RETURNS: if (sl_info_p ^= null ()) then do; sl_info.num_paths = original_num_paths; /* not strictly necessary, but let's */ free sl_info in (system_area); /* be polite to PL/I here */ end; if (seg_info_ptr = null ()) then return ("0"b); /* Major failure */ return (seg_info.count > 0); /* Consider it OK if there are any */ end get_seg_info; /* */ search_list_changed: procedure () returns (bit (1) aligned); dcl idx fixed bin; dcl change_idx fixed bin (71) based; dcl time_compiled fixed bin (71); if (change_idx_ptr = null ()) then goto UPDATE; /* First time */ if (change_idx_ptr -> change_idx ^= last_change_idx) then goto UPDATE; /* It's changed */ if (seg_info_ptr = null ()) then goto UPDATE; /* In case something's screwed up */ if (seg_info.count <= 0) then goto UPDATE; on condition (seg_fault_error) goto UPDATE; on condition (not_in_read_bracket) goto UPDATE; on condition (no_read_permission) goto UPDATE; on condition (out_of_bounds) goto UPDATE; do idx = 1 to seg_info.count; /* Try to reference each one */ time_compiled = seg_info.header_ptr (idx) -> std_symbol_header.object_created; if (time_compiled ^= seg_info.time_compiled (idx)) then goto UPDATE; end; return ("0"b); /* If we make it through, nothing has changed, */ /* and nothing needs recalculation */ UPDATE: return ("1"b); /* one of the segments in the list */ end search_list_changed; /* */ /* This procedure fills in seg_info information for the requested segment. A bit is returned indicating whether the segment could be found or not, and whether it turned out to be in the right format. */ find_segment: procedure (P_pathname, P_seg_info_ptr, P_report_errors) returns (bit (1) aligned); dcl P_pathname char (*) parameter; dcl P_seg_info_ptr pointer parameter; dcl P_report_errors bit (1) aligned parameter; dcl 1 P_seg_info aligned like seg_info_entry based (P_seg_info_ptr); dcl dname char (168); dcl ename char (32); dcl component char (32); dcl bitcount fixed bin (24); dcl segp pointer; dcl report_errors bit (1) aligned; /* First, locate the segment in the hierarchy, and get a pointer to it */ report_errors = P_report_errors; call locate_segment (); go to COMMON; find_segment$$analyze: entry (P_segp, P_bitcount, P_comp_name, P_seg_info_ptr) returns (bit (1) aligned); declare P_bitcount fixed bin (24); declare P_segp pointer; declare P_comp_name char (*); segp = P_segp; bitcount = P_bitcount; ename = P_comp_name; /* for component_info */ report_errors = "0"b; COMMON: /* Now, try to find the symbol table header (these structure library segments are Multics standard object segments), and find the root of the PL/I block tree */ call analyze_segment (); call find_structure_list (); return ("1"b); /* If we get here, it worked */ FIND_SEGMENT_FAILS: return ("0"b); invalid_segment: procedure (error_code); dcl error_code fixed bin (35) parameter; if report_errors then call com_err_ (error_code, WHOAMI, "^a>^a.^/^3xRemoving it from the ^a search list.", dname, ename, SDL_LIST_NAME); code = error_code; goto FIND_SEGMENT_FAILS; end invalid_segment; /* */ locate_segment: /* Procedure internal to find_segment */ procedure (); call expand_pathname_$component (P_pathname, dname, ename, component, code); if code ^= 0 then do; if report_errors then call com_err_ (code, WHOAMI, "^a", P_pathname); goto FIND_SEGMENT_FAILS; end; call initiate_file_$component (dname, ename, component, R_ACCESS, segp, bitcount, code); if code ^= 0 then call invalid_segment (code); if (bitcount = 0) then call invalid_segment (error_table_$zero_length_seg); P_seg_info.seg_ptr = segp; P_seg_info.pathname = pathname_$component (dname, ename, component); P_seg_info.name = ename; return; end locate_segment; /* */ analyze_segment: procedure (); dcl 1 oi aligned like object_info automatic; dcl hp pointer; dcl bp pointer; dcl rootp pointer; oi.version_number = object_info_version_2; call object_info_$brief (segp, bitcount, addr (oi), code); if (code ^= 0) then call invalid_segment (code); P_seg_info.time_compiled = oi.symbp -> std_symbol_header.object_created; if oi.bound then do; /* Get info about the component, then */ call component_info_$name (segp, ename, addr (ci), code); if (code ^= 0) then call invalid_segment (code); hp= ci.symb_start; end; else hp= oi.symbp; /* Only one for an unbound segment */ if (hp -> std_symbol_header.identifier ^= "symbtree") then call invalid_segment (error_table_$oldobj); if (hp -> std_symbol_header.area_pointer = ""b) then call invalid_segment (error_table_$oldobj); bp = addrel (hp, hp -> std_symbol_header.area_pointer); if (bp -> pl1_symbol_block.identifier ^= "pl1info") then call invalid_segment (error_table_$oldobj); rootp = addrel (hp, bp -> pl1_symbol_block.root); if (rel (rootp) = ""b) then call invalid_segment (error_table_$oldobj); rootp = addrel (rootp, rootp -> runtime_block.son); /* Look in the outermost "real" block */ if (rel (rootp) = ""b) then call invalid_segment (error_table_$oldobj); P_seg_info.header_ptr = hp; P_seg_info.pl1_root = rootp; return; end analyze_segment; /* */ find_structure_list: procedure (); dcl symp pointer; dcl idx fixed bin; dcl known_list (P_seg_info.known_list_size) char (32) unaligned based (P_seg_info.known_list_ptr); P_seg_info.known_list_ptr = null (); P_seg_info.known_list_size = 0; symp = stu_$find_runtime_symbol (P_seg_info.pl1_root, "STRUCTURES", (null ()), code); if (symp = null ()) then return; /* No list of defined structures in this segment */ if (binary (symp -> runtime_symbol.type, 6) ^= char_dtype) then goto INVALID; if (binary (symp -> runtime_symbol.ndims, 6) ^= 1) then goto INVALID; if (symp -> runtime_symbol.size ^= 32) then goto INVALID; if (symp -> runtime_symbol.bounds (1).lower ^= 1) then goto INVALID; if (symp -> runtime_symbol.bounds (1).upper > 1000) then goto INVALID; if (symp -> runtime_symbol.address.class ^= "1100"b) then goto INVALID; P_seg_info.known_list_ptr = pointer (symp, symp -> runtime_symbol.address.location); P_seg_info.known_list_size = symp -> runtime_symbol.bounds (1).upper; do idx = 1 to P_seg_info.known_list_size /* Trim off blank entries */ while (known_list (idx) ^= ""); P_seg_info.known_list_size = idx; end; return; INVALID: if report_errors then call com_err_ (0, WHOAMI, "The ""STRUCTURES"" list of known structures in ^a^/^3x must be declared as dim (XXX) char (32) internal static options (constant).", pathname_$component (dname, ename, component)); code = error_table_$bad_segment; goto FIND_SEGMENT_FAILS; end find_structure_list; end find_segment; %page; %include sl_info; %page; %include sl_control_s; %page; %include object_info; %page; %include component_info; %page; %include std_symbol_header; %page; %include pl1_symbol_block; %page; %include runtime_symbol; %page; %include std_descriptor_types; end structure_lib_mgr_; /* external procedure */  structure_ref_.pl1 11/19/84 1143.5rew 11/15/84 1440.1 110970 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ structure_ref_: procedure (); /* * STRUCTURE_REF_ * * This procedure parses a reference to a PL/I variable; it is used * by analyze_multics to implement the structure display facility. * A subset of PL/I syntax is permitted: reference either to scalar * variables or to structures, with subscripts. The subscripts must * be decimal integers, and the ":" syntax may be used to indicate * a cross-section. Either parentheses or braces may be used to * indicate subscripts, to avoid command processor problems. * * The structure reference may be followed by one or more names, * separated by slashes, which can be interpreted by the caller as * as substrings on which to match to select elements of the structure. * There must be a slash between the structure reference and the first * match string, and a slash between each pair of match strings. An * optional slash may be supplied at the end, for compatibility with * qedx syntax. * * The results of the parse are a top level name, a fully qualified * structure name (suitable for use with stu_), and a subscript * array for use with display_data_. * * Examples: * * pvt pvt.array pvt.array{13} * pvt/volmap/ pvt.array{1:4}/volmap/ * * 4 Jun 83, WOS: Initial coding */ declare P_reference char (*) parameter; /* Input: name to resolve */ declare P_structure char (*) parameter; /* Output: Top level structure name */ declare P_full_name char (*) parameter; /* Output: fully qualified name */ declare P_subscripts (2, *) fixed bin parameter; /* Output: cross-section bounds */ declare P_n_subscripts fixed bin parameter; /* Output: how many subscripts are valid */ declare P_substrings (*) char (*) varying parameter; /* Output: substrings to match in reference */ declare P_n_substrings fixed bin parameter; /* Output: how many substrings there are */ declare P_code fixed bin (35) parameter; declare code fixed bin (35); declare reference char (256) varying; declare top_name char (64) varying; declare full_name char (256) varying; declare subscript_idx fixed bin; declare n_subscripts fixed bin; declare n_substrings fixed bin; declare n_tokens fixed bin; declare n_reference_tokens fixed bin; declare 1 token (-1 : 80), 2 type fixed bin, 2 start fixed bin, 2 lth fixed bin; declare TOKEN_BLANK init (1) fixed bin internal static options (constant); declare TOKEN_NUMBER init (2) fixed bin internal static options (constant); declare TOKEN_NAME init (3) fixed bin internal static options (constant); declare TOKEN_DOT init (4) fixed bin internal static options (constant); declare TOKEN_COMMA init (5) fixed bin internal static options (constant); declare TOKEN_COLON init (6) fixed bin internal static options (constant); declare TOKEN_OPEN init (7) fixed bin internal static options (constant); declare TOKEN_CLOSE init (8) fixed bin internal static options (constant); declare TOKEN_SLASH init (9) fixed bin internal static options (constant); declare LOWER fixed bin internal static options (constant) init (1); declare UPPER fixed bin internal static options (constant) init (2); declare (subscriptrange, stringsize, conversion) condition; declare (addr, fixed, index, null, substr) builtin; /* */ structure_ref_$parse: entry (P_reference, P_structure, P_full_name, P_subscripts, P_n_subscripts, P_substrings, P_n_substrings, P_code); /* These catch all the cases of too mayy subscripts, too many names, etc. It might be nice to give real error messages for these, but it's a lot of trouble, and the syntax of structure references is pretty simple. The conditions are selectively enabled for the statements where we want to detect that they have been raised. */ on condition (stringsize) goto SYNTAX_ERROR; on condition (subscriptrange) goto SYNTAX_ERROR; on condition (conversion) goto SYNTAX_ERROR; P_structure = ""; P_full_name = ""; P_n_subscripts = 0; P_n_substrings = 0; reference = rtrim (P_reference); call parse_reference (); call parse_reference_tokens (); call parse_substring_tokens (); P_structure = top_name; P_full_name = full_name; P_n_subscripts = n_subscripts; P_n_substrings = n_substrings; P_code = 0; return; SYNTAX_ERROR: P_code = code; return; /* */ parse_reference: procedure (); declare char_idx fixed bin; declare token_idx fixed bin; declare state fixed bin; declare action fixed bin; declare this_type fixed bin; declare this_char char (1) unaligned; declare CHAR_WHITE init (1) fixed bin internal static options (constant); declare CHAR_SPECIAL init (2) fixed bin internal static options (constant); declare CHAR_DIGIT init (3) fixed bin internal static options (constant); declare CHAR_ALPHA init (4) fixed bin internal static options (constant); declare STATE_NONE init (1) fixed bin internal static options (constant); declare STATE_NAME init (2) fixed bin internal static options (constant); declare STATE_NUMBER init (3) fixed bin internal static options (constant); declare ACTION_INVALID init (1) fixed bin internal static options (constant); declare ACTION_DONE init (2) fixed bin internal static options (constant); declare ACTION_ADD init (3) fixed bin internal static options (constant); declare ACTION (3, 4) internal static options (constant) init (3, 2, 2, 2, 2, 2, 3, 3, 2, 2, 3, 1); declare STATE (3, 4) internal static options (constant) init (1, 1, 3, 2, 1, 1, 2, 2, 1, 1, 3, 1); /* */ do token_idx = lbound (token, 1) to 1; /* Make spurious tokens for backward references */ token.type (token_idx) = TOKEN_BLANK; end; state = STATE_NONE; token_idx = 1; do char_idx = 1 to length (reference); this_char = substr (reference, char_idx, 1); this_type = char_type (this_char); action = ACTION (state, this_type); state = STATE (state, this_type); if (action = ACTION_INVALID) then do; code = char_idx; goto SYNTAX_ERROR; end; else if (action = ACTION_ADD) then do; if (this_type ^= CHAR_WHITE) then token.lth (token_idx) = token.lth (token_idx) + 1; end; else if (action = ACTION_DONE) then do; if (token.type (token_idx) ^= TOKEN_BLANK) then token_idx = token_idx + 1; (subscriptrange): /* To catch too many tokens */ token.lth (token_idx) = 1; token.start (token_idx) = char_idx; if (this_type = CHAR_WHITE) then token.type (token_idx) = TOKEN_BLANK; else if (this_type = CHAR_DIGIT) then token.type (token_idx) = TOKEN_NUMBER; else if (this_type) = CHAR_ALPHA then token.type (token_idx) = TOKEN_NAME; else if (this_char = ".") then token.type (token_idx) = TOKEN_DOT; else if (this_char = ",") then token.type (token_idx) = TOKEN_COMMA; else if (this_char = ":") then token.type (token_idx) = TOKEN_COLON; else if (this_char = "(") | (this_char = "{") then token.type (token_idx) = TOKEN_OPEN; else if (this_char = ")") | (this_char = "}") then token.type (token_idx) = TOKEN_CLOSE; else if (this_char = "/") then token.type (token_idx) = TOKEN_SLASH; else do; code = char_idx; goto SYNTAX_ERROR; end; end; end; if (token.type (token_idx) = TOKEN_BLANK) then n_tokens = token_idx - 1; else n_tokens = token_idx; do token_idx = 1 to n_tokens while (token (token_idx).type ^= TOKEN_SLASH); end; if (token_idx > n_tokens) then n_reference_tokens = n_tokens; else n_reference_tokens = token_idx - 1; return; /* */ char_type: procedure (one_char) returns (fixed bin); declare one_char char (1) unaligned parameter; if (one_char = " ") then return (CHAR_WHITE); if (index (".,:(){}/", one_char) ^= 0) then return (CHAR_SPECIAL); if (index ("0123456789", one_char) ^= 0) then return (CHAR_DIGIT); if (index ("_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ", one_char) ^= 0) then return (CHAR_ALPHA); code = char_idx; goto SYNTAX_ERROR; end char_type; end parse_reference; /* */ parse_reference_tokens: procedure (); declare token_idx fixed bin; declare this_type fixed bin; declare next_type fixed bin; declare this_token char (64) varying; if (token.type (1) ^= TOKEN_NAME) then do; code = 1; goto SYNTAX_ERROR; end; full_name = ""; token_idx = 0; n_subscripts = 0; do while (token_idx < n_reference_tokens); call next_reference_token (); if (this_type = TOKEN_NAME) then do; if (token_idx < n_reference_tokens) then if (next_type ^= TOKEN_DOT) & (next_type ^= TOKEN_OPEN) then call reference_token_error (); if (length (full_name) ^= 0) then full_name = full_name || "."; else top_name = this_token; /* First time through, set the structure top level name */ (stringsize): full_name = full_name || this_token; end; else if (this_type = TOKEN_OPEN) | (this_type = TOKEN_COMMA) then do; if (next_type ^= TOKEN_NUMBER) then call reference_token_error (); call next_reference_token (); if (next_type ^= TOKEN_CLOSE) & (next_type ^= TOKEN_COMMA) & (next_type ^= TOKEN_COLON) then call reference_token_error (); n_subscripts = n_subscripts + 1; (conversion, subscriptrange): P_subscripts (LOWER, n_subscripts) = fixed (this_token); if (next_type ^= TOKEN_COLON) then P_subscripts (UPPER, n_subscripts) = P_subscripts (LOWER, n_subscripts); else do; call next_reference_token (); /* Skip the colon */ call next_reference_token (); /* and get the second subscript */ if (this_type ^= TOKEN_NUMBER) then call reference_token_error (); if (next_type ^= TOKEN_COMMA) & (next_type ^= TOKEN_CLOSE) then call reference_token_error (); (conversion, subscriptrange): P_subscripts (UPPER, n_subscripts) = fixed (this_token); end; end; /* Of subscript case */ else if (this_type = TOKEN_CLOSE) then; /* run out of subscripts */ else if (this_type = TOKEN_DOT) then do; if (next_type ^= TOKEN_NAME) then goto SYNTAX_ERROR; end; else call reference_token_error (); end; return; /* */ next_reference_token: procedure (); if (token_idx = n_reference_tokens) then call reference_token_error (); token_idx = token_idx + 1; this_type = token.type (token_idx); next_type = token.type (token_idx + 1); this_token = substr (reference, token.start (token_idx), token.lth (token_idx)); return; end next_reference_token; reference_token_error: procedure (); code = token.start (token_idx); goto SYNTAX_ERROR; end reference_token_error; end parse_reference_tokens; /* */ parse_substring_tokens: procedure (); declare token_idx fixed bin; declare first_token fixed bin; declare last_token fixed bin; n_substrings = 0; first_token = n_reference_tokens + 1; /* First slash */ if (first_token > n_tokens) then return; /* no substrings */ if (token.type (n_tokens) = TOKEN_SLASH) then /* Allow a lone slash at the end of the reference */ last_token = n_tokens - 1; /* but don't require it */ else last_token = n_tokens; do token_idx = first_token to last_token; if (token.type (token_idx) ^= TOKEN_SLASH) then goto SUBSTRING_ERROR; if (token_idx = last_token) then /* Not enough */ goto SUBSTRING_ERROR; token_idx = token_idx + 1; /* Move to the name */ if (token.type (token_idx) ^= TOKEN_NAME) then goto SUBSTRING_ERROR; n_substrings = n_substrings + 1; (subscriptrange): P_substrings (n_substrings) = substr (reference, token.start (token_idx), token.lth (token_idx)); end; return; SUBSTRING_ERROR: code = token_idx; goto SYNTAX_ERROR; end parse_substring_tokens; end structure_ref_; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- 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