



		    bce_create_sstnt.pl1            11/11/89  1133.6r w 11/11/89  0825.6       96876



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(86-01-14,Fawcett), approve(86-04-11,MCR7383),
     audit(86-05-12,Farley), install(86-07-17,MR12.0-1097):
     Add support for devices using 512_WORD_IO
  2) change(87-02-04,Farley), approve(87-04-15,MCR7660),
     audit(87-04-16,Lippard), install(87-04-28,MR12.1-1028):
     Changed to correct the calculation of vtoc_offset.
                                                   END HISTORY COMMENTS */


bce_create_sstnt: proc (sst_abs_start, sst_abs_end);

/* Program to generate the sst_names_ segment for Multics within bce.
Written August 1984 by Keith Loepere. */

/* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */

/* The sst_names_ segment gives the name of the segment corresponding to each 
aste.  The segment may be maintained by Multics, by specifying the "astk"
parm, or by this program.  The sst_names_ maintained by this program fetches
the name for an aste from the corresponding vtoce. */

/* Parameters */

dcl  sst_abs_end			fixed bin (26) parameter;
dcl  sst_abs_start			fixed bin (26) parameter;

/* Constants */

dcl  ME				char (12) init ("create_sstnt") static options (constant);
dcl  page_table_sizes		(0:3) fixed bin init (4, 16, 64, 256) static options (constant);

/* Entries */

dcl  bce_appending_simulation$get_absolute entry (fixed bin (26), fixed bin (18), ptr, fixed bin (35));
dcl  bce_appending_simulation$get_virtual entry (ptr, fixed bin (26), fixed bin (18), ptr, fixed bin (35));
dcl  bce_appending_simulation$new_segment entry (fixed bin (15), ptr, fixed bin (35));
dcl  bce_appending_simulation$put_virtual entry (ptr, fixed bin (26), fixed bin (18), ptr, fixed bin (35));
dcl  bce_check_abort		entry;
dcl  com_err_			entry () options (variable);
dcl  ioa_				entry () options (variable);
dcl  read_disk$read_disk_no_test	entry (fixed bin, fixed bin (18), ptr, fixed bin (35));

/* Variables */

dcl  aste_num			fixed bin;	/* loop index on astes in a pool */
dcl  aste_pool			fixed bin;	/* loop index on aste pools */
dcl  code				fixed bin (35);
dcl  1 my_aste			aligned like aste;	/* read in aste */
dcl  1 my_sstnt_seg_info		aligned like seg_info; /* description of sstnt */
dcl  sst_buffer			bit (36 * 1024) aligned; /* fetch the sst a page at a time for efficiency */
dcl  sst_buffer_offset		fixed bin (18);	/* this ptr shows how much of page buffer we've processed */
dcl  sst_name			char (32) var;	/* element of sst_names_ */
dcl  sst_seg_offset			fixed bin (26);	/* of data in sst_buffer */
dcl  sst_sizes			(0:3) fixed bin;	/* size of pools */
dcl  sstnt_buffer			bit (36 * 1024) aligned; /* write the sstnt a page at a time for efficiency */
dcl  sstnt_buffer_offset		fixed bin (18);	/* this ptr shows how much of page buffer we've processed */
dcl  sstnt_header_size		fixed bin (18);	/* everything before the names */
dcl  sstnt_seg_offset		fixed bin (26);	/* of start of data in sstnt_buffer */
dcl  vtoc_offset			fixed bin;	/* offset of desired vtoce within page */
dcl  vtoc_record			bit (36 * 1024) aligned; /* for reading vtoces */
dcl  vtoc_record_num		fixed bin (18);	/* page number holding vtoce */

/* Misc */

dcl  addr				builtin;
dcl  addrel			builtin;
dcl  currentsize			builtin;
dcl  divide			builtin;
dcl  max				builtin;
dcl  min				builtin;
dcl  mod				builtin;
dcl  rtrim			builtin;
dcl  segno			builtin;
dcl  size				builtin;
dcl  substr			builtin;
dcl  unspec			builtin;
dcl  wordno			builtin;
%page;
	seg_info_ptr = addr (my_sstnt_seg_info);
	call bce_appending_simulation$new_segment (segno (addr (sst_names_$)), seg_info_ptr, code);
	if code ^= 0 then go to sstnt_error;

	sstnp = addr (sstnt_buffer);			/* fetch current sst_names_ header */
	sstnt_header_size = wordno (addr (sstnt.names)) - wordno (sstnp);
	call bce_appending_simulation$get_virtual (seg_info_ptr, 0, sstnt_header_size, sstnp, code);
	if code ^= 0 then go to sstnt_error;

/* Now for some validity checks on sst_names_. */

	if sstnt.valid & sstnt.multics_or_bce = "mult" then return;
	if sstnt.ast_sizes (0) ^= page_table_sizes (0) + size (aste) |
	     sstnt.ast_sizes (1) ^= page_table_sizes (1) + size (aste) |
	     sstnt.ast_sizes (2) ^= page_table_sizes (2) + size (aste) |
	     sstnt.ast_sizes (3) ^= page_table_sizes (3) + size (aste) then return; /* not initialized */

	sst_sizes (0) = sstnt.ast_name_offsets (1);	/* size of pools */
	sst_sizes (1) = sstnt.ast_name_offsets (2) - sstnt.ast_name_offsets (1);
	sst_sizes (2) = sstnt.ast_name_offsets (3) - sstnt.ast_name_offsets (2);
	sst_sizes (3) = sstnt.nentries - sstnt.ast_name_offsets (3);

	if sstnt.ast_offsets (1) ^= sstnt.ast_offsets (0) + /* check pool sizes versus supplied offsets */
	     sst_sizes (0) * (page_table_sizes (0) + size (aste)) then return;
	if sstnt.ast_offsets (2) ^= sstnt.ast_offsets (1) +
	     sst_sizes (1) * (page_table_sizes (1) + size (aste)) then return;
	if sstnt.ast_offsets (3) ^= sstnt.ast_offsets (2) +
	     sst_sizes (2) * (page_table_sizes (2) + size (aste)) then return;
	if sst_abs_end - sst_abs_start + 1 < sstnt.ast_offsets (3) +
	     sst_sizes (3) * (page_table_sizes (3) + size (aste)) then return;
	if seg_info.size < currentsize (sstnt) then return; /* sstnt not big enough for names - not made paged yet? */

/* We keep a (1 page) buffer of the sst at all times for efficiency.  For our
purposes, we don't need the sst header.  We'll start reading with the start
of the astes.  So, we start by fetching that buffers' worth of the sst that
contains the start of the astes. */

	sst_seg_offset = sstnt.ast_offsets (0);
	sst_buffer_offset = mod (sst_seg_offset, size (sst_buffer));
	call bce_appending_simulation$get_absolute (sst_abs_start + sst_seg_offset - sst_buffer_offset, size (sst_buffer), addr (sst_buffer), code);

/* We also keep a (1 page) buffer of the sstnt waiting to be written.  Start
us out as writing after the header (which we'll write later). */

	sstnt_buffer_offset = sstnt_header_size;
	sstnt_seg_offset = 0;

	sstnt.multics_or_bce = "bce";
	sstnt.valid = "1"b;

	call ioa_ ("Filling sst_names_");
%page;
	astep = addr (my_aste);

/* Read each aste.  For all valid ones, grab the name from the vtoce. */

	pvt_arrayp = addr (pvt$array);

	do aste_pool = 0 to 3;
	     do aste_num = 1 to sst_sizes (aste_pool);
		sst_name = "";
		call get_next_aste (page_table_sizes (aste_pool));
		if aste.uid = "0"b then go to next_aste;
		if aste.uid = "777777777777"b3 then do;
		     sst_name = ">";
		     go to next_aste;
		end;
		if aste.hc then go to next_aste;
		if aste.vtocx = -1 then go to next_aste;
		if aste.pvtx > pvt$max_n_entries then goto next_aste;
		pvtep = addr (pvt_array (aste.pvtx));
		vtoc_record_num = VTOC_ORIGIN + divide (aste.vtocx, VTOCES_PER_RECORD (pvte.device_type), 17);
		vtoc_offset = sect_per_vtoc (pvte.device_type) * words_per_sect (pvte.device_type) * mod (aste.vtocx, VTOCES_PER_RECORD (pvte.device_type));
		call read_disk$read_disk_no_test ((aste.pvtx), vtoc_record_num, addr (vtoc_record), code);
		if code ^= 0 then go to next_aste;
		vtocep = addrel (addr (vtoc_record), vtoc_offset);
		sst_name = rtrim (vtoce.primary_name);

next_aste:	call add_name_to_sstnt;
		call bce_check_abort;
	     end;
	end;
	call add_name_to_sstnt$flush;
	return;

sstnt_error:
	call com_err_ (code, ME);
	return;
%page;
add_name_to_sstnt: proc;

/* This subproc adds sst_name to the end of sstnt_buffer.  If this
runs off the end, the current buffer is written and the excess added to the
new buffer's worth. */

dcl  sst_name_bits			bit (size (sst_name) * 36) aligned based (addr (sst_name));
dcl  words_in_current_page		fixed bin;
dcl  words_in_new_page		fixed bin;

	words_in_current_page = min (size (sstnt_buffer) - sstnt_buffer_offset, size (sst_name));
	substr (sstnt_buffer, 1 + sstnt_buffer_offset * 36, words_in_current_page * 36) =
	     substr (sst_name_bits, 1, words_in_current_page * 36);
	sstnt_buffer_offset = sstnt_buffer_offset + words_in_current_page;

	if sstnt_buffer_offset = size (sstnt_buffer) then do;
	     call bce_appending_simulation$put_virtual (seg_info_ptr, sstnt_seg_offset, size (sstnt_buffer), addr (sstnt_buffer), code);
	     sstnt_seg_offset = sstnt_seg_offset + size (sstnt_buffer);

	     words_in_new_page = size (sst_name) - words_in_current_page;
	     substr (sstnt_buffer, 1, words_in_new_page * 36) =
		substr (sst_name_bits, 1 + words_in_current_page * 36, words_in_new_page * 36);
	     sstnt_buffer_offset = words_in_new_page;
	end;
	return;

add_name_to_sstnt$flush: entry;

	call bce_appending_simulation$put_virtual (seg_info_ptr, sstnt_seg_offset, sstnt_buffer_offset, addr (sstnt_buffer), code);
	return;
     end add_name_to_sstnt;
%page;
get_next_aste: proc (page_table_size);

/* This subproc returns the next aste in the sst.  It skips over the page 
table.  It reads in the next page of sst if necessary to do this. */

dcl  page_table_size		fixed bin parameter;

dcl  aste_size			fixed bin;
dcl  words_in_current_page		fixed bin;
dcl  words_in_page_to_be_fetched	fixed bin;
dcl  words_to_copy			fixed bin;

	aste_size = page_table_size + size (aste);
	words_in_current_page = min (size (sst_buffer) - sst_buffer_offset, aste_size);
	words_to_copy = min (words_in_current_page, size (aste));
	substr (unspec (aste), 1, words_to_copy * 36) =
	     substr (sst_buffer, 1 + sst_buffer_offset * 36, words_to_copy * 36);
	sst_seg_offset = sst_seg_offset + words_in_current_page;
	sst_buffer_offset = sst_buffer_offset + words_in_current_page;

	if sst_buffer_offset >= size (sst_buffer) then do;
	     call bce_appending_simulation$get_absolute (sst_abs_start + sst_seg_offset, size (sst_buffer), addr (sst_buffer), code);

	     words_in_page_to_be_fetched = aste_size - words_in_current_page;
	     words_to_copy = max (size (aste) - words_in_current_page, 0);
	     substr (unspec (aste), 1 + words_in_current_page * 36, words_to_copy * 36) =
		substr (sst_buffer, 1, words_to_copy * 36);
	     sst_seg_offset = sst_seg_offset + words_in_page_to_be_fetched;
	     sst_buffer_offset = words_in_page_to_be_fetched;
	end;
	return;
     end get_next_aste;
%page; %include bce_appending_seg_info;
%page; %include disk_pack;
%page; %include fs_dev_types_sector;
%page; %include ptw_info;
%page; %include pvte;
%page; %include sstnt;
%page; %include vtoce;
     end bce_create_sstnt;




		    bce_dump.pl1                    11/11/89  1133.6r w 11/11/89  0825.6      245574



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(86-01-14,Fawcett), approve(86-04-11,MCR7383),
     audit(86-05-12,Farley), install(86-07-17,MR12.0-1097):
     Change the call to find_partition$given_drive for subvolumes
                                                   END HISTORY COMMENTS */


bce_dump: proc (ss_info_ptr);

/* Program to perform a disk dump of a crashed Multics system within
bootload Multics.
Written November 1983 by Keith Loepere. */
/* Modified August 1984 by Keith Loepere for sstnt option and to change defaults. */
/* Modified November 1984 by M. Pandolf to include hc_lock. */
/* Modified January 1985 by Keith Loepere for new find_partition,
   and to get severity right. */

/* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */

/* Names of process categories and options. */

dcl  All				fixed bin init (1) static options (constant); /* process_group_num */
dcl  Directories			fixed bin init (1) static options (constant); /* segment_group_num */
dcl  Eligible			fixed bin init (2) static options (constant); /* process_group_num */
dcl  Hardcore			fixed bin init (2) static options (constant); /* segment_group_num */
dcl  Initializer			fixed bin init (3) static options (constant); /* process_group_num */
dcl  Modifying_dirs			fixed bin init (3) static options (constant); /* segment_group_num */
dcl  Per_process			fixed bin init (4) static options (constant); /* segment_group_num */
dcl  Process_group_names		(4) char (32) static options (constant) init
				("-all", "-eligible", "-initializer", "-running");
dcl  Process_group_names_short	(4) char (5) static options (constant) init
				("-all", "-elig", "-inzr", "-run");
dcl  Running			fixed bin init (4) static options (constant); /* process_group_num */
dcl  Segment_group_names		(6) char (32) static options (constant) init
				("directories", "hardcore", "modifying_dirs", "per_process", "stacks", "writeable");
dcl  Segment_group_names_short	(6) char (6) static options (constant) init
				("dir", "hc", "moddir", "pp", "stk", "wrt");
dcl  Stacks			fixed bin init (5) static options (constant); /* segment_group_num */
dcl  Writeable			fixed bin init (6) static options (constant); /* segment_group_num */

dcl  addcharno			builtin;
dcl  addr				builtin;
dcl  addrel			builtin;
dcl  after			builtin;
dcl  apte_num			fixed bin;	/* loop var */
dcl  arg				char (arg_len) based (arg_ptr);
dcl  arg_len			fixed bin (21);
dcl  arg_num			fixed bin;	/* loop var */
dcl  arg_ptr			ptr;
dcl  before			builtin;
dcl  bce_appending_simulation$get_absolute entry (fixed bin (26), fixed bin (18), ptr, fixed bin (35));
dcl  bce_appending_simulation$get_virtual entry (ptr, fixed bin (26), fixed bin (18), ptr, fixed bin (35));
dcl  bce_appending_simulation$init	entry (bit (1) aligned, fixed bin (35));
dcl  bce_appending_simulation$new_dbr	entry (bit (72) aligned, fixed bin (15), fixed bin (35));
dcl  bce_appending_simulation$new_sdw	entry (fixed bin (71), ptr, fixed bin (35));
dcl  bce_appending_simulation$new_segment entry (fixed bin (15), ptr, fixed bin (35));
dcl  bce_check_abort		entry;
dcl  bce_create_sstnt		entry (fixed bin (26), fixed bin (26));
dcl  bce_query$yes_no		entry options (variable);
dcl  bin				builtin;
dcl  bit				builtin;
dcl  clock			builtin;
dcl  code				fixed bin (35);
dcl  com_err_			entry () options (variable);
dcl  crash_dbr			bit (72) aligned;
dcl  crash_dbr_addr			fixed bin (26);
dcl  create_sstnt			bit (1) aligned;
dcl  cu_$arg_count_rel		entry (fixed bin, ptr, fixed bin (35));
dcl  cu_$arg_ptr_rel		entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  current_dbr			bit (72) aligned;
dcl  current_dump_record		fixed bin (18);	/* record on disk of start of this segment */
dcl  cv_dec_check_			entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  dbr_util_$dissect		entry (ptr, ptr);
dcl  dimension			builtin;
dcl  directory_mod			bit (36) aligned;	/* modify field of dir */
dcl  divide			builtin;
dcl  drive_num			char (4);
dcl  dump_severity			fixed bin init (3) static;
dcl  dseg$			external;
dcl  dseg_buffer			(0:511) fixed bin (71); /* buffer page of dseg to optimize sdw checking */
dcl  1 dseg_info			aligned like seg_info;
dcl  dseg_no			fixed bin (15);	/* segno of dseg */
dcl  dump_astep			ptr;		/* for dump_seg */
dcl  dump_disk_pvid			bit (36) aligned;
dcl  dump_disk_pvtx			fixed bin;
dcl  dump_drive_name		char (8);
dcl  dump_number			fixed bin;	/* user supplied */
dcl  dump_options			(4) bit (6) aligned;/* options for processes to dump (process_group_num, segment_group_num) */
dcl  dump_ptp			ptr;		/* page table for dump_seg */
dcl  dump_seg$			external;		/* mapped onto dump partition */
dcl  dumped_hc_seg			(0:255) bit (1) unal; /* set true when we succeed in dumping hc seg n */
dcl  error_table_$bad_arg		fixed bin (35) ext static;
dcl  error_table_$noarg		fixed bin (35) ext static;
dcl  examine_crash			bit (1) aligned;
dcl  find_partition			entry (char (*), fixed bin, bit (36) aligned, fixed bin (18), fixed bin (18), fixed bin (35));
dcl  find_partition$given_drive	entry (char (*), char (4), char (4), fixed bin, bit (36) aligned, fixed bin (18), fixed bin (18), fixed bin (35));
dcl  first_dump_record		fixed bin (18);	/* first record in partition */
dcl  force			bit (1) aligned;
dcl  get_ptrs_$given_segno		entry (fixed bin (15)) returns (ptr);
dcl  hbound			builtin;
dcl  hreg				fixed bin;	/* loop var */
dcl  i				fixed bin;	/* loop var */
dcl  ioa_				entry () options (variable);
dcl  kst_no			fixed bin (15);	/* segno of kst */
dcl  kst_seg$			external;
dcl  last_apte			fixed bin;	/* range of aptes to dump */
dcl  last_segnum			fixed bin (15);	/* range of valid segnos */
dcl  lbound			builtin;
dcl  me				char (8) static init ("bce_dump") options (constant);
dcl  min				builtin;
dcl  mod				builtin;
dcl  1 my_apte			aligned like apte;
dcl  1 my_aste			aligned like aste;
dcl  1 my_dbr_info			aligned like dbr_info;
dcl  1 my_dump			aligned like dump;
dcl  my_page_buffer			bit (1024 * 36) aligned;
dcl  1 my_ptw_info			aligned like ptw_info;
dcl  1 my_sdw_info			aligned like sdw_info;
dcl  1 my_seg_info			aligned like seg_info;
dcl  n_args			fixed bin;	/* command line args */
dcl  not_option			bit (1) aligned;	/* true => use not of current option */
dcl  null_page			bit (1) aligned;	/* false => found non-null page in segment */
dcl  num_pages			fixed bin;	/* in segment to dump */
dcl  num_records			fixed bin (18);	/* in dump part */
dcl  page_buffer			bit (1024 * 36) aligned based;
dcl  page_num			fixed bin;	/* loop var */
dcl  pc$cleanup			entry (ptr);
dcl  pds$				external;
dcl  pds_no			fixed bin (15);	/* segno of pds */
dcl  prds$			external;
dcl  prds_no			fixed bin (15);	/* segno of prds */
dcl  proc_options			bit (6) unal;	/* options (segment_group_num) for segments for this proc */
dcl  process_group_num		fixed bin;	/* loop var */
dcl  processed_crash_dbr		bit (1) aligned;	/* true when we found the apte for the crashing process */
dcl  ptw_util_$dissect		entry (ptr, ptr);
dcl  ptw_util_$make_null_disk		entry (ptr, fixed bin (20));
dcl  read_disk			entry (fixed bin, fixed bin (18), ptr, fixed bin (35));
dcl  request_abort_			condition;
dcl  rsw_util$port_info		entry (fixed bin (3), bit (1) aligned, fixed bin, fixed bin, fixed bin (3));
dcl  scu_base			fixed bin;
dcl  scu_enabled			bit (1) aligned;
dcl  scu_interlace			fixed bin (3);
dcl  scu_size			fixed bin;
dcl  scu_tag			fixed bin (3);
dcl  sdw_util_$dissect		entry (ptr, ptr);
dcl  seg_sdw			fixed bin (71) based (seg_sdw_ptr);
dcl  seg_sdw_ptr			ptr;
dcl  segment_group_num		fixed bin;	/* loop var */
dcl  segno			builtin;
dcl  segnum			fixed bin (15);	/* loop var */
dcl  size				builtin;
dcl  sst_bit_map			bit (16384) aligned;/* map which implies which astes have been dumped, figuring that each aste/pt takes at least 16 words */
dcl  sst_end			fixed bin (26);	/* range of addresses for sst page segs */
dcl  sst_index			fixed bin;	/* index into sst_bit_map for this apparent aste */
dcl  sst_seg$			external;
dcl  sst_start			fixed bin (26);
dcl  substr			builtin;
dcl  subsystem			char (4);
dcl  sys_boot_info$bce_dbr		bit (72) aligned external;
dcl  sys_info$clock_		bit (3) aligned external;
dcl  tc_data$			external;
dcl  tc_data_addr			fixed bin (26);	/* absadr */
dcl  tc_data_no			fixed bin (15);	/* segno of tc_data */
dcl  1 toehold$			aligned like toe_hold external;
dcl  unspec			builtin;
dcl  wordno			builtin;
dcl  write_disk			entry (fixed bin, fixed bin (18), ptr, fixed bin (35));
dcl  yes_no			bit (1);
%page;

/* Start by finding supplied dump options. */

	dump_severity = 2;
	unspec (dump_options) = "0"b;
	dump_number = 0;
	force = "0"b;
	create_sstnt = "1"b;			/* defaults */
	dump_drive_name = "";
	examine_crash = (sys_info$collection_1_phase = CRASH_INITIALIZATION | sys_info$collection_1_phase = BCE_CRASH_INITIALIZATION);
	call cu_$arg_count_rel (n_args, ss_info.arg_list_ptr, code);
	if code ^= 0 then signal request_abort_;

	if n_args = 0 then do;
	     call ioa_ ("Usage is: dump <options> {-force | -fc}.");
	     call ioa_ ("Options are:");
	     call ioa_ ("   -dump #");
	     call ioa_ ("   -sstnt | -no_sstnt");
	     call ioa_ ("   -drive | -dv <name>");
	     call ioa_ ("   -brief | -bf | -standard | -std | -long | -lg");
	     call ioa_ ("   -crash | -bce");
	     call ioa_ ("   <-process_group> <segment options>");
	     call ioa_ ("   Process groups are:");
	     do i = 1 to dimension (Process_group_names, 1);
		call ioa_ ("      ^a ^a", Process_group_names (i), Process_group_names_short (i));
	     end;
	     call ioa_ ("   Segment options are:");
	     do i = 1 to dimension (Segment_group_names, 1);
		call ioa_ ("      ^a ^a", Segment_group_names (i), Segment_group_names_short (i));
	     end;
	     return;
	end;

	arg_num = 1;
	do while (arg_num <= n_args);
	     call cu_$arg_ptr_rel (arg_num, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
	     arg_num = arg_num + 1;
	     if arg = "-dump" then do;
		if arg_num > n_args then do;
		     call com_err_ (error_table_$noarg, me, "dump number");
		     return;
		end;
		call cu_$arg_ptr_rel (arg_num, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
		arg_num = arg_num + 1;
		dump_number = cv_dec_check_ (arg, code);
		if code ^= 0 then do;
		     call com_err_ (0, me, "Bad dump number. ^a", arg);
		     return;
		end;
	     end;
	     else if arg = "-drive" | arg = "-dv" then do;
		if arg_num > n_args then do;
		     call com_err_ (error_table_$noarg, me, "drive name");
		     return;
		end;
		call cu_$arg_ptr_rel (arg_num, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
		arg_num = arg_num + 1;
		dump_drive_name = arg;
	     end;
	     else if arg = "-force" | arg = "-fc" then force = "1"b;
	     else if arg = "-crash" then examine_crash = "1"b;
	     else if arg = "-bce" then examine_crash = "0"b;
	     else if arg = "-sstnt" then create_sstnt = "1"b;
	     else if arg = "-no_sstnt" then create_sstnt = "0"b;
	     else if arg = "-brief" | arg = "-bf" then do;
		unspec (dump_options) = "0"b;
		substr (dump_options (Running), Hardcore, 1) = "1"b;
		substr (dump_options (Running), Modifying_dirs, 1) = "1"b;
		substr (dump_options (Running), Per_process, 1) = "1"b;
	     end;
	     else if arg = "-standard" | arg = "-std" then do;
		unspec (dump_options) = "0"b;
		substr (dump_options (Running), Hardcore, 1) = "1"b;
		substr (dump_options (Running), Modifying_dirs, 1) = "1"b;
		substr (dump_options (Running), Per_process, 1) = "1"b;
		substr (dump_options (Eligible), Hardcore, 1) = "1"b;
		substr (dump_options (Eligible), Stacks, 1) = "1"b;
		dump_options (Initializer) = dump_options (Eligible);
	     end;
	     else if arg = "-long" | arg = "-lg" then do;
		unspec (dump_options) = "0"b;
		substr (dump_options (All), Writeable, 1) = "1"b;
	     end;
	     else do;
		do process_group_num = 1 to dimension (Process_group_names, 1)
		     while (Process_group_names (process_group_num) ^= arg & Process_group_names_short (process_group_num) ^= arg);
		end;
		if process_group_num > dimension (Process_group_names, 1) then do;
		     call com_err_ (error_table_$bad_arg, me, "^a", arg);
		     return;
		end;
		if arg_num > n_args then do;
		     call com_err_ (error_table_$noarg, me, "segment group options");
		     return;
		end;
next_segment_option:
		call cu_$arg_ptr_rel (arg_num, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
		if arg_len > 0 then
		     if substr (arg, 1, 1) = "^" then do;
			not_option = "1"b;
			arg_len = arg_len - 1;
			arg_ptr = addcharno (arg_ptr, 1); /* eat not flag */
		     end;
		     else not_option = "0"b;
		else not_option = "0"b;
		do segment_group_num = 1 to dimension (Segment_group_names, 1)
		     while (Segment_group_names (segment_group_num) ^= arg & Segment_group_names_short (segment_group_num) ^= arg);
		end;
		if segment_group_num <= dimension (Segment_group_names, 1) then do;
		     substr (dump_options (process_group_num), segment_group_num, 1) = ^not_option;
		     arg_num = arg_num + 1;
		     if arg_num <= n_args then go to next_segment_option;
						/* else we fall through and see this ctl-arg on next loop up */
		end;
	     end;
	end;

	dump_options (Eligible) = dump_options (Eligible) | dump_options (All); /* merge options */
	dump_options (Running) = dump_options (Running) | dump_options (Eligible);
	call ioa_ ("Dumping ^[Multics image^;bce^].", examine_crash);
%page;

/* Setup and initialization. */

	if examine_crash then crash_dbr = toehold$.multics_state.dbr;
	else crash_dbr = sys_boot_info$bce_dbr;
	dbr_info_ptr = addr (my_dbr_info);
	call dbr_util_$dissect (addr (crash_dbr), dbr_info_ptr);
	crash_dbr_addr = dbr_info.address;

	dumpptr = addr (my_dump);
	call bce_appending_simulation$init (examine_crash, code);
	if code ^= 0 then do;
apnd_error:    call com_err_ (code, me, "appending simulation package");
	     return;
	end;

	if dump_drive_name = "" then call find_partition ("dump", dump_disk_pvtx, dump_disk_pvid, first_dump_record, num_records, code);
	else do;					/* oper supplied drive */
	     subsystem = before (dump_drive_name, "_");
	     drive_num = after (dump_drive_name, "_");
	     if code ^= 0 then do;
		call com_err_ (0, me, "Bad dump partition drive_name.");
		return;
	     end;
	     call find_partition$given_drive ("dump", subsystem, drive_num, dump_disk_pvtx, dump_disk_pvid, first_dump_record, num_records, code);
	end;
	if code ^= 0 then do;
dump_partition_error:
	     call com_err_ (code, me, "dump partition");
	     return;
	end;

/* Get current header. */

	call read_disk (dump_disk_pvtx, first_dump_record, dumpptr, code);
	if code ^= 0 then go to dump_partition_error;

	if dump.valid then
	     if ^force then do;
		call bce_query$yes_no (yes_no, "dump: The dump partition contains the supposedly valid dump #^d.^/Do you wish to overwrite it? ", dump.erfno);
		if ^yes_no then do;
		     dump_severity = 1;
		     return;
		end;
	     end;

	dump.valid = "0"b;
	if dump_number > 0 then dump.erfno = dump_number;
	else dump.erfno = dump.erfno + 1;
	call ioa_ ("Dump #^d", dump.erfno);
	call write_disk (dump_disk_pvtx, first_dump_record, dumpptr, code); /* hedge against crash */
	if code ^= 0 then go to dump_partition_error;

	dump.words_dumped = 0;
	begin;
dcl  kludge_valid			bit (36) aligned based (addr (dump.valid));
	     kludge_valid = "111111111111111111111111111111111111"b; /* azm expects it */
	end;
	dump.time = clock;				/* fill in header */
	dump.num_segs = 0;
	dump.valid_355 = "0"b;
	dump.dumped_355s = "0"b;
	dump.time_355 = 0;
	dump.version = DUMP_VERSION_2;

/* save the various toehold information into the header. */

	dump.dbr = crash_dbr;
	dump.low_order_port = sys_info$clock_;
	if examine_crash then do;
	     dump.amptwregs = toehold$.ptwam_regs;
	     dump.amptwptrs = toehold$.ptwam_ptrs;
	     dump.amsdwregs = toehold$.sdwam_regs;
	     dump.amsdwptrs = toehold$.sdwam_ptrs;
	     do hreg = 0 to 15;
		dump.ouhist (hreg) = toehold$.ou_history_registers (hreg);
		dump.cuhist (hreg) = toehold$.cu_history_registers (hreg);
		dump.duhist (hreg) = toehold$.du_history_registers (hreg);
		dump.auhist (hreg) = toehold$.apu_history_registers (hreg);
	     end;
	     dump.prs = toehold$.mc_.prs;
	     unspec (dump.regs) = unspec (toehold$.mc_.regs);
	     dump.mctime = bin (toehold$.mc_.fault_time, 54);
	     unspec (dump.scu) = unspec (toehold$.mc_.scu);
	     unspec (dump.mcm) = unspec (toehold$.masks);
	     substr (dump.intrpts, 1, 16) = substr (toehold$.interrupt, 1, 16);
	     substr (dump.intrpts, 17, 16) = substr (toehold$.interrupt, 37, 16);
	     dump.bar = toehold$.bar;
	     dump.modereg = toehold$.mode_reg;
	     dump.cmodereg = toehold$.cache_mode_reg;
	     dump.faultreg = toehold$.mc_.fault_reg;
	     dump.ptrlen = toehold$.mc_.eis_info;
	end;
	do scu_tag = lbound (dump.coreblocks.num_first, 1) to hbound (dump.coreblocks.num_first, 1);
	     call rsw_util$port_info (scu_tag, scu_enabled, scu_base, scu_size, scu_interlace);
	     dump.coreblocks.num_first (scu_tag) = bit (scu_base, 18);
	     dump.coreblocks.num_blocks (scu_tag) = bit (scu_size, 18);
	end;
%page;
	current_dump_record = first_dump_record + 66;	/* 2 for header and 64 for (obsolete) fnp dumping */
	dseg_no = segno (addr (dseg$));		/* interesting per-process(or) segments */
	pds_no = segno (addr (pds$));
	prds_no = segno (addr (prds$));
	kst_no = segno (addr (kst_seg$));

	aptep = addr (my_apte);			/* ptrs to local copies of things */
	sdw_info_ptr = addr (my_sdw_info);
	ptw_info_ptr = addr (my_ptw_info);
	seg_info_ptr = addr (my_seg_info);
	astep = addr (my_aste);
	dp = addr (directory_mod);
	dump_astep = get_ptrs_$given_segno (segno (addr (dump_seg$)));
	dump_ptp = addrel (dump_astep, size (aste));
	dump_astep -> aste.pvtx = dump_disk_pvtx;
	do page_num = 0 to 255;
	     call ptw_util_$make_null_disk (addrel (dump_ptp, page_num), first_dump_record + page_num); /* safe initial state */
	end;

/* Find range of aptes to dump from tc_data. */

	tcmp = addr (tc_data$);
	tc_data_no = segno (addr (tc_data$));

	call bce_appending_simulation$new_segment (tc_data_no, seg_info_ptr, code);
	if code ^= 0 then last_apte = 0;
	else do;
	     if seg_info.paged then do;
		call ptw_util_$dissect (addr (seg_info.page_table (0)), ptw_info_ptr);
		tc_data_addr = ptw_info.address;
	     end;
	     else tc_data_addr = seg_info.address;
	     call bce_appending_simulation$get_absolute (tc_data_addr + wordno (addr (tcm.apt_size)), 1, addr (last_apte), code);
	     if code ^= 0 then last_apte = 0;
	end;


/* Get sst bounds (for finding sst paged segments). */

	sst_start = 0; sst_end = -1;
	call bce_appending_simulation$new_segment (segno (addr (sst_seg$)), seg_info_ptr, code);
	if code = 0 then do;
	     if seg_info.paged then do;
		call ptw_util_$dissect (addr (seg_info.page_table (0)), ptw_info_ptr);
		sst_start = ptw_info.address;
	     end;
	     else sst_start = seg_info.address;
	     sst_end = sst_start + seg_info.size - 1;
	end;

	processed_crash_dbr = "0"b;
	dumped_hc_seg (*) = "0"b;
	sst_bit_map = "0"b;

	if create_sstnt then call bce_create_sstnt (sst_start, sst_end);
%page;

/* Walk down through aptes, dumping what the operator wants dumped for each one. */

/* We iterate over all aptes in tc_data.  When we find the apte that matches
the process that crashed, we set processed_crash_dbr.  Otherwise, this isn't 
set and we make one more pass (0) which picks this process up. */

	do apte_num = 1 to last_apte, 0 while (^processed_crash_dbr); /* include dbr in machine conditions */
	     call bce_check_abort;			/* operator wants to stop? */

	     if apte_num > 0 then do;			/* else using crash dbr */
		call bce_appending_simulation$get_absolute (tc_data_addr + wordno (addr (tcm.apt)) + (apte_num - 1) * size (apte), size (apte), aptep, code);
		if code ^= 0 then go to next_apte;
		if apte.state = Empty_apte then go to next_apte;
		current_dbr = unspec (apte.dbr);

/* Find options that apply to this process. */

		if dump_options (Running) ^= "0"b & (apte.dbr_loaded | apte.state = Stopped_apte) then proc_options = dump_options (Running);
		else if apte.eligible then proc_options = dump_options (Eligible);
		else proc_options = dump_options (All);
		if apte_num = 1 then proc_options = proc_options | dump_options (Initializer); /* inzr is first apte */
	     end;
	     else do;
		current_dbr = crash_dbr;
		proc_options = dump_options (Running) | dump_options (Initializer); /* grab all you can */
	     end;

	     call dbr_util_$dissect (addr (current_dbr), dbr_info_ptr);
	     if dbr_info.address = crash_dbr_addr then processed_crash_dbr = "1"b;
	     if proc_options = "0"b then go to next_apte; /* not interesting */
	     substr (proc_options, Hardcore, 1) = "1"b;	/* need to dump these, if any, so that process is 
						visible in dump (a decrease in segnos appears) */

	     call bce_appending_simulation$new_dbr (current_dbr, last_segnum, code);
	     if code ^= 0 then go to next_apte;
	     call bce_appending_simulation$new_segment (dseg_no, addr (dseg_info), code);
	     if code ^= 0 then go to next_apte;

	     call ioa_ ("proc ^o, dbr = ^24.3b", apte_num, current_dbr);
%page;

/* Process segments desired. */

	     do segnum = 0 to last_segnum;
		call bce_check_abort;		/* last chance for operator to stop */

/* optimization - keep around a page of dseg; see if an sdw is faulted before
expending new_segment on it */

		if mod (segnum, dimension (dseg_buffer, 1)) = 0 then /* crossed into next buffer of sdw's (next dseg page) */
		     call bce_appending_simulation$get_virtual (addr (dseg_info), segnum * 2, size (dseg_buffer), addr (dseg_buffer), code); /* zero sdw's on error */
		seg_sdw_ptr = addr (dseg_buffer (mod (segnum, dimension (dseg_buffer, 1))));
		call sdw_util_$dissect (seg_sdw_ptr, sdw_info_ptr);
		if sdw_info.faulted then go to next_seg;

		call bce_appending_simulation$new_sdw (seg_sdw, seg_info_ptr, code);
		if code ^= 0 then go to next_seg;

/* See if we should dump this segment. */

		if substr (proc_options, Hardcore, 1) then
		     if segnum = dseg_no | segnum = pds_no | segnum = prds_no | segnum = kst_no then go to dump_seg;
		if ^seg_info.write then go to next_seg;
		if dbr_info.stack_base_segnum = 0	/* idle or initialization (all segs hc) */
		     | segnum < dbr_info.stack_base_segnum then /* hc seg */
		     if segnum > hbound (dumped_hc_seg, 1) then go to dump_seg;
		     else if ^dumped_hc_seg (segnum) then do;
			dumped_hc_seg (segnum) = "1"b;
			go to dump_seg;		/* dump for first proc */
		     end;
		     else go to next_seg;		/* not for others */
		if substr (proc_options, Stacks, 1) & (dbr_info.stack_base_segnum <= segnum & segnum < dbr_info.stack_base_segnum + 8) then go to dump_seg; /* stacks */
		if ^seg_info.paged then go to dump_seg; /* unpaged non-hardcore - rare */
		if sst_start > 0 then do;		/* there was a sst */
		     if seg_info.address < sst_start | sst_end < seg_info.address then go to dump_seg; /* not sst paged seg - rare for non-hc */

/* We now have a non-hardcore standard paged segment. */

		     if ^substr (proc_options, Writeable, 1) then do; /* if we don't want all writable, segments need some justification */
			if seg_info.sst_data.per_process & substr (proc_options, Per_process, 1) then go to consider_seg;
			if seg_info.sst_data.dirsw then do;
			     if substr (proc_options, Directories, 1) then go to consider_seg;
			     if substr (proc_options, Modifying_dirs, 1) then do;
				call bce_appending_simulation$get_virtual (seg_info_ptr, wordno (addr (dir.modify)) - wordno (dp), 1, dp, code);
				if dir.modify then go to consider_seg;
			     end;
			end;
			go to next_seg;
		     end;
consider_seg:

/* We want to dump this segment.  First, though, we ask if we dumped it before
(we have processed its aste before).  Since no two astes can fit in the same
16 words of memory (they are at least 16 words long), we can divide the sst
into 16 word blocks.  If two segments claim different (starting) blocks, we
say they have different astes and are different segments. */

		     sst_index = divide (seg_info.address - sst_start + 8, 16, 14) + 1;
		     if substr (sst_bit_map, sst_index, 1) then go to next_seg; /* already dumped */
		     substr (sst_bit_map, sst_index, 1) = "1"b;
		end;
		else go to next_seg;
%page;
dump_seg:

/* Time to dump this segment.  See if it will fit. */

		if dump.num_segs = dimension (dump.segs, 1) then do;
		     call ioa_ ("Segment array overflow.");
		     go to end_dump;
		end;
		dump.num_segs = dump.num_segs + 1;
		dump.segs.segno (dump.num_segs) = bit (bin (segnum, 18), 18);
		dump.segs.length (dump.num_segs) = "0"b;

/* Map dump_seg onto next area of dump part. */

		num_pages = divide (seg_info.size + 1023, 1024, 8);
		if current_dump_record + num_pages > first_dump_record + num_records then do;
		     call ioa_ ("Dump partition overflow.");
		     go to end_dump;
		end;
		do page_num = 0 to num_pages - 1;
		     call ptw_util_$make_null_disk (addrel (dump_ptp, page_num), current_dump_record + page_num);
		end;

/* We must find the last non-zero page.  After this, we move it into dump_seg
and then page the rest of the segment into there.  We read the segment 
backwards, for possible i/o latency improvement. */

		null_page = "1"b;
		do page_num = num_pages - 1 to 0 by -1 while (null_page);
		     call bce_appending_simulation$get_virtual (seg_info_ptr, page_num * 1024, min (1024, seg_info.size - page_num * 1024), addr (my_page_buffer), code);
		     if my_page_buffer ^= "0"b then null_page = "0"b;
		end;
		if null_page then go to next_seg;	/* empty seg */
		page_num = page_num + 1;		/* last non-null page */
		addrel (addr (dump_seg$), page_num * 1024) -> page_buffer = my_page_buffer;
		if page_num > 0 then
		     call bce_appending_simulation$get_virtual (seg_info_ptr, 0, min (seg_info.size, page_num * 1024), addr (dump_seg$), code);
		call pc$cleanup (dump_astep);		/* write out */
		current_dump_record = current_dump_record + page_num + 1;
		dump.segs.length (dump.num_segs) = bit (bin ((page_num + 1) * 16, 18), 18);
		dump.words_dumped = dump.words_dumped + (page_num + 1) * 1024;
next_seg:
	     end;
next_apte:
	end;

	dump_severity = 0;				/* all done! */
%page;
end_dump:

/* Write out header */

	call write_disk (dump_disk_pvtx, first_dump_record + 1, addrel (dumpptr, 1024), code);
	call write_disk (dump_disk_pvtx, first_dump_record, dumpptr, code);
	return;
%page;
severity: entry () returns (fixed bin);

	return (dump_severity);
%page; %include apte;
%page; %include bce_appending_seg_info;
%page; %include bce_subsystem_info_;
%page; %include bos_dump;
%page; %include collection_1_phases;
%page; %include dbr_info;
%page; %include dir_header;
%page; %include ptw_info;
%page; %include state_equs;
%page; %include tcm;
%page; %include hc_lock;
%page; %include toe_hold;
     end;





		    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
