1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1987                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1984 *
  6         *                                                         *
  7         *********************************************************** */
  8 
  9 
 10 /****^  HISTORY COMMENTS:
 11   1) change(86-01-14,Fawcett), approve(86-04-11,MCR7383),
 12      audit(86-05-12,Farley), install(86-07-17,MR12.0-1097):
 13      Change the call to find_partition$given_drive for subvolumes
 14                                                    END HISTORY COMMENTS */
 15 
 16 
 17 bce_dump: proc (ss_info_ptr);
 18 
 19 /* Program to perform a disk dump of a crashed Multics system within
 20 bootload Multics.
 21 Written November 1983 by Keith Loepere. */
 22 /* Modified August 1984 by Keith Loepere for sstnt option and to change defaults. */
 23 /* Modified November 1984 by M. Pandolf to include hc_lock. */
 24 /* Modified January 1985 by Keith Loepere for new find_partition,
 25    and to get severity right. */
 26 
 27 /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */
 28 
 29 /* Names of process categories and options. */
 30 
 31 dcl  All                                fixed bin init (1) static options (constant); /* process_group_num */
 32 dcl  Directories                        fixed bin init (1) static options (constant); /* segment_group_num */
 33 dcl  Eligible                           fixed bin init (2) static options (constant); /* process_group_num */
 34 dcl  Hardcore                           fixed bin init (2) static options (constant); /* segment_group_num */
 35 dcl  Initializer                        fixed bin init (3) static options (constant); /* process_group_num */
 36 dcl  Modifying_dirs                     fixed bin init (3) static options (constant); /* segment_group_num */
 37 dcl  Per_process                        fixed bin init (4) static options (constant); /* segment_group_num */
 38 dcl  Process_group_names                (4) char (32) static options (constant) init
 39                                         ("-all", "-eligible", "-initializer", "-running");
 40 dcl  Process_group_names_short          (4) char (5) static options (constant) init
 41                                         ("-all", "-elig", "-inzr", "-run");
 42 dcl  Running                            fixed bin init (4) static options (constant); /* process_group_num */
 43 dcl  Segment_group_names                (6) char (32) static options (constant) init
 44                                         ("directories", "hardcore", "modifying_dirs", "per_process", "stacks", "writeable");
 45 dcl  Segment_group_names_short          (6) char (6) static options (constant) init
 46                                         ("dir", "hc", "moddir", "pp", "stk", "wrt");
 47 dcl  Stacks                             fixed bin init (5) static options (constant); /* segment_group_num */
 48 dcl  Writeable                          fixed bin init (6) static options (constant); /* segment_group_num */
 49 
 50 dcl  addcharno                          builtin;
 51 dcl  addr                               builtin;
 52 dcl  addrel                             builtin;
 53 dcl  after                              builtin;
 54 dcl  apte_num                           fixed bin;          /* loop var */
 55 dcl  arg                                char (arg_len) based (arg_ptr);
 56 dcl  arg_len                            fixed bin (21);
 57 dcl  arg_num                            fixed bin;          /* loop var */
 58 dcl  arg_ptr                            ptr;
 59 dcl  before                             builtin;
 60 dcl  bce_appending_simulation$get_absolute entry (fixed bin (26), fixed bin (18), ptr, fixed bin (35));
 61 dcl  bce_appending_simulation$get_virtual entry (ptr, fixed bin (26), fixed bin (18), ptr, fixed bin (35));
 62 dcl  bce_appending_simulation$init      entry (bit (1) aligned, fixed bin (35));
 63 dcl  bce_appending_simulation$new_dbr   entry (bit (72) aligned, fixed bin (15), fixed bin (35));
 64 dcl  bce_appending_simulation$new_sdw   entry (fixed bin (71), ptr, fixed bin (35));
 65 dcl  bce_appending_simulation$new_segment entry (fixed bin (15), ptr, fixed bin (35));
 66 dcl  bce_check_abort                    entry;
 67 dcl  bce_create_sstnt                   entry (fixed bin (26), fixed bin (26));
 68 dcl  bce_query$yes_no                   entry options (variable);
 69 dcl  bin                                builtin;
 70 dcl  bit                                builtin;
 71 dcl  clock                              builtin;
 72 dcl  code                               fixed bin (35);
 73 dcl  com_err_                           entry () options (variable);
 74 dcl  crash_dbr                          bit (72) aligned;
 75 dcl  crash_dbr_addr                     fixed bin (26);
 76 dcl  create_sstnt                       bit (1) aligned;
 77 dcl  cu_$arg_count_rel                  entry (fixed bin, ptr, fixed bin (35));
 78 dcl  cu_$arg_ptr_rel                    entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
 79 dcl  current_dbr                        bit (72) aligned;
 80 dcl  current_dump_record                fixed bin (18);     /* record on disk of start of this segment */
 81 dcl  cv_dec_check_                      entry (char (*), fixed bin (35)) returns (fixed bin (35));
 82 dcl  dbr_util_$dissect                  entry (ptr, ptr);
 83 dcl  dimension                          builtin;
 84 dcl  directory_mod                      bit (36) aligned;   /* modify field of dir */
 85 dcl  divide                             builtin;
 86 dcl  drive_num                          char (4);
 87 dcl  dump_severity                      fixed bin init (3) static;
 88 dcl  dseg$                              external;
 89 dcl  dseg_buffer                        (0:511) fixed bin (71); /* buffer page of dseg to optimize sdw checking */
 90 dcl  1 dseg_info                        aligned like seg_info;
 91 dcl  dseg_no                            fixed bin (15);     /* segno of dseg */
 92 dcl  dump_astep                         ptr;                /* for dump_seg */
 93 dcl  dump_disk_pvid                     bit (36) aligned;
 94 dcl  dump_disk_pvtx                     fixed bin;
 95 dcl  dump_drive_name                    char (8);
 96 dcl  dump_number                        fixed bin;          /* user supplied */
 97 dcl  dump_options                       (4) bit (6) aligned;/* options for processes to dump (process_group_num, segment_group_num) */
 98 dcl  dump_ptp                           ptr;                /* page table for dump_seg */
 99 dcl  dump_seg$                          external;           /* mapped onto dump partition */
100 dcl  dumped_hc_seg                      (0:255) bit (1) unal; /* set true when we succeed in dumping hc seg n */
101 dcl  error_table_$bad_arg               fixed bin (35) ext static;
102 dcl  error_table_$noarg                 fixed bin (35) ext static;
103 dcl  examine_crash                      bit (1) aligned;
104 dcl  find_partition                     entry (char (*), fixed bin, bit (36) aligned, fixed bin (18), fixed bin (18), fixed bin (35));
105 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));
106 dcl  first_dump_record                  fixed bin (18);     /* first record in partition */
107 dcl  force                              bit (1) aligned;
108 dcl  get_ptrs_$given_segno              entry (fixed bin (15)) returns (ptr);
109 dcl  hbound                             builtin;
110 dcl  hreg                               fixed bin;          /* loop var */
111 dcl  i                                  fixed bin;          /* loop var */
112 dcl  ioa_                               entry () options (variable);
113 dcl  kst_no                             fixed bin (15);     /* segno of kst */
114 dcl  kst_seg$                           external;
115 dcl  last_apte                          fixed bin;          /* range of aptes to dump */
116 dcl  last_segnum                        fixed bin (15);     /* range of valid segnos */
117 dcl  lbound                             builtin;
118 dcl  me                                 char (8) static init ("bce_dump") options (constant);
119 dcl  min                                builtin;
120 dcl  mod                                builtin;
121 dcl  1 my_apte                          aligned like apte;
122 dcl  1 my_aste                          aligned like aste;
123 dcl  1 my_dbr_info                      aligned like dbr_info;
124 dcl  1 my_dump                          aligned like dump;
125 dcl  my_page_buffer                     bit (1024 * 36) aligned;
126 dcl  1 my_ptw_info                      aligned like ptw_info;
127 dcl  1 my_sdw_info                      aligned like sdw_info;
128 dcl  1 my_seg_info                      aligned like seg_info;
129 dcl  n_args                             fixed bin;          /* command line args */
130 dcl  not_option                         bit (1) aligned;    /* true => use not of current option */
131 dcl  null_page                          bit (1) aligned;    /* false => found non-null page in segment */
132 dcl  num_pages                          fixed bin;          /* in segment to dump */
133 dcl  num_records                        fixed bin (18);     /* in dump part */
134 dcl  page_buffer                        bit (1024 * 36) aligned based;
135 dcl  page_num                           fixed bin;          /* loop var */
136 dcl  pc$cleanup                         entry (ptr);
137 dcl  pds$                               external;
138 dcl  pds_no                             fixed bin (15);     /* segno of pds */
139 dcl  prds$                              external;
140 dcl  prds_no                            fixed bin (15);     /* segno of prds */
141 dcl  proc_options                       bit (6) unal;       /* options (segment_group_num) for segments for this proc */
142 dcl  process_group_num                  fixed bin;          /* loop var */
143 dcl  processed_crash_dbr                bit (1) aligned;    /* true when we found the apte for the crashing process */
144 dcl  ptw_util_$dissect                  entry (ptr, ptr);
145 dcl  ptw_util_$make_null_disk           entry (ptr, fixed bin (20));
146 dcl  read_disk                          entry (fixed bin, fixed bin (18), ptr, fixed bin (35));
147 dcl  request_abort_                     condition;
148 dcl  rsw_util$port_info                 entry (fixed bin (3), bit (1) aligned, fixed bin, fixed bin, fixed bin (3));
149 dcl  scu_base                           fixed bin;
150 dcl  scu_enabled                        bit (1) aligned;
151 dcl  scu_interlace                      fixed bin (3);
152 dcl  scu_size                           fixed bin;
153 dcl  scu_tag                            fixed bin (3);
154 dcl  sdw_util_$dissect                  entry (ptr, ptr);
155 dcl  seg_sdw                            fixed bin (71) based (seg_sdw_ptr);
156 dcl  seg_sdw_ptr                        ptr;
157 dcl  segment_group_num                  fixed bin;          /* loop var */
158 dcl  segno                              builtin;
159 dcl  segnum                             fixed bin (15);     /* loop var */
160 dcl  size                               builtin;
161 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 */
162 dcl  sst_end                            fixed bin (26);     /* range of addresses for sst page segs */
163 dcl  sst_index                          fixed bin;          /* index into sst_bit_map for this apparent aste */
164 dcl  sst_seg$                           external;
165 dcl  sst_start                          fixed bin (26);
166 dcl  substr                             builtin;
167 dcl  subsystem                          char (4);
168 dcl  sys_boot_info$bce_dbr              bit (72) aligned external;
169 dcl  sys_info$clock_                    bit (3) aligned external;
170 dcl  tc_data$                           external;
171 dcl  tc_data_addr                       fixed bin (26);     /* absadr */
172 dcl  tc_data_no                         fixed bin (15);     /* segno of tc_data */
173 dcl  1 toehold$                         aligned like toe_hold external;
174 dcl  unspec                             builtin;
175 dcl  wordno                             builtin;
176 dcl  write_disk                         entry (fixed bin, fixed bin (18), ptr, fixed bin (35));
177 dcl  yes_no                             bit (1);
178 %page;
179 
180 /* Start by finding supplied dump options. */
181 
182           dump_severity = 2;
183           unspec (dump_options) = "0"b;
184           dump_number = 0;
185           force = "0"b;
186           create_sstnt = "1"b;                              /* defaults */
187           dump_drive_name = "";
188           examine_crash = (sys_info$collection_1_phase = CRASH_INITIALIZATION | sys_info$collection_1_phase = BCE_CRASH_INITIALIZATION);
189           call cu_$arg_count_rel (n_args, ss_info.arg_list_ptr, code);
190           if code ^= 0 then signal request_abort_;
191 
192           if n_args = 0 then do;
193                call ioa_ ("Usage is: dump <options> {-force | -fc}.");
194                call ioa_ ("Options are:");
195                call ioa_ ("   -dump #");
196                call ioa_ ("   -sstnt | -no_sstnt");
197                call ioa_ ("   -drive | -dv <name>");
198                call ioa_ ("   -brief | -bf | -standard | -std | -long | -lg");
199                call ioa_ ("   -crash | -bce");
200                call ioa_ ("   <-process_group> <segment options>");
201                call ioa_ ("   Process groups are:");
202                do i = 1 to dimension (Process_group_names, 1);
203                     call ioa_ ("      ^a ^a", Process_group_names (i), Process_group_names_short (i));
204                end;
205                call ioa_ ("   Segment options are:");
206                do i = 1 to dimension (Segment_group_names, 1);
207                     call ioa_ ("      ^a ^a", Segment_group_names (i), Segment_group_names_short (i));
208                end;
209                return;
210           end;
211 
212           arg_num = 1;
213           do while (arg_num <= n_args);
214                call cu_$arg_ptr_rel (arg_num, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
215                arg_num = arg_num + 1;
216                if arg = "-dump" then do;
217                     if arg_num > n_args then do;
218                          call com_err_ (error_table_$noarg, me, "dump number");
219                          return;
220                     end;
221                     call cu_$arg_ptr_rel (arg_num, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
222                     arg_num = arg_num + 1;
223                     dump_number = cv_dec_check_ (arg, code);
224                     if code ^= 0 then do;
225                          call com_err_ (0, me, "Bad dump number. ^a", arg);
226                          return;
227                     end;
228                end;
229                else if arg = "-drive" | arg = "-dv" then do;
230                     if arg_num > n_args then do;
231                          call com_err_ (error_table_$noarg, me, "drive name");
232                          return;
233                     end;
234                     call cu_$arg_ptr_rel (arg_num, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
235                     arg_num = arg_num + 1;
236                     dump_drive_name = arg;
237                end;
238                else if arg = "-force" | arg = "-fc" then force = "1"b;
239                else if arg = "-crash" then examine_crash = "1"b;
240                else if arg = "-bce" then examine_crash = "0"b;
241                else if arg = "-sstnt" then create_sstnt = "1"b;
242                else if arg = "-no_sstnt" then create_sstnt = "0"b;
243                else if arg = "-brief" | arg = "-bf" then do;
244                     unspec (dump_options) = "0"b;
245                     substr (dump_options (Running), Hardcore, 1) = "1"b;
246                     substr (dump_options (Running), Modifying_dirs, 1) = "1"b;
247                     substr (dump_options (Running), Per_process, 1) = "1"b;
248                end;
249                else if arg = "-standard" | arg = "-std" then do;
250                     unspec (dump_options) = "0"b;
251                     substr (dump_options (Running), Hardcore, 1) = "1"b;
252                     substr (dump_options (Running), Modifying_dirs, 1) = "1"b;
253                     substr (dump_options (Running), Per_process, 1) = "1"b;
254                     substr (dump_options (Eligible), Hardcore, 1) = "1"b;
255                     substr (dump_options (Eligible), Stacks, 1) = "1"b;
256                     dump_options (Initializer) = dump_options (Eligible);
257                end;
258                else if arg = "-long" | arg = "-lg" then do;
259                     unspec (dump_options) = "0"b;
260                     substr (dump_options (All), Writeable, 1) = "1"b;
261                end;
262                else do;
263                     do process_group_num = 1 to dimension (Process_group_names, 1)
264                          while (Process_group_names (process_group_num) ^= arg & Process_group_names_short (process_group_num) ^= arg);
265                     end;
266                     if process_group_num > dimension (Process_group_names, 1) then do;
267                          call com_err_ (error_table_$bad_arg, me, "^a", arg);
268                          return;
269                     end;
270                     if arg_num > n_args then do;
271                          call com_err_ (error_table_$noarg, me, "segment group options");
272                          return;
273                     end;
274 next_segment_option:
275                     call cu_$arg_ptr_rel (arg_num, arg_ptr, arg_len, code, ss_info.arg_list_ptr);
276                     if arg_len > 0 then
277                          if substr (arg, 1, 1) = "^" then do;
278                               not_option = "1"b;
279                               arg_len = arg_len - 1;
280                               arg_ptr = addcharno (arg_ptr, 1); /* eat not flag */
281                          end;
282                          else not_option = "0"b;
283                     else not_option = "0"b;
284                     do segment_group_num = 1 to dimension (Segment_group_names, 1)
285                          while (Segment_group_names (segment_group_num) ^= arg & Segment_group_names_short (segment_group_num) ^= arg);
286                     end;
287                     if segment_group_num <= dimension (Segment_group_names, 1) then do;
288                          substr (dump_options (process_group_num), segment_group_num, 1) = ^not_option;
289                          arg_num = arg_num + 1;
290                          if arg_num <= n_args then go to next_segment_option;
291                                                             /* else we fall through and see this ctl-arg on next loop up */
292                     end;
293                end;
294           end;
295 
296           dump_options (Eligible) = dump_options (Eligible) | dump_options (All); /* merge options */
297           dump_options (Running) = dump_options (Running) | dump_options (Eligible);
298           call ioa_ ("Dumping ^[Multics image^;bce^].", examine_crash);
299 %page;
300 
301 /* Setup and initialization. */
302 
303           if examine_crash then crash_dbr = toehold$.multics_state.dbr;
304           else crash_dbr = sys_boot_info$bce_dbr;
305           dbr_info_ptr = addr (my_dbr_info);
306           call dbr_util_$dissect (addr (crash_dbr), dbr_info_ptr);
307           crash_dbr_addr = dbr_info.address;
308 
309           dumpptr = addr (my_dump);
310           call bce_appending_simulation$init (examine_crash, code);
311           if code ^= 0 then do;
312 apnd_error:    call com_err_ (code, me, "appending simulation package");
313                return;
314           end;
315 
316           if dump_drive_name = "" then call find_partition ("dump", dump_disk_pvtx, dump_disk_pvid, first_dump_record, num_records, code);
317           else do;                                          /* oper supplied drive */
318                subsystem = before (dump_drive_name, "_");
319                drive_num = after (dump_drive_name, "_");
320                if code ^= 0 then do;
321                     call com_err_ (0, me, "Bad dump partition drive_name.");
322                     return;
323                end;
324                call find_partition$given_drive ("dump", subsystem, drive_num, dump_disk_pvtx, dump_disk_pvid, first_dump_record, num_records, code);
325           end;
326           if code ^= 0 then do;
327 dump_partition_error:
328                call com_err_ (code, me, "dump partition");
329                return;
330           end;
331 
332 /* Get current header. */
333 
334           call read_disk (dump_disk_pvtx, first_dump_record, dumpptr, code);
335           if code ^= 0 then go to dump_partition_error;
336 
337           if dump.valid then
338                if ^force then do;
339                     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);
340                     if ^yes_no then do;
341                          dump_severity = 1;
342                          return;
343                     end;
344                end;
345 
346           dump.valid = "0"b;
347           if dump_number > 0 then dump.erfno = dump_number;
348           else dump.erfno = dump.erfno + 1;
349           call ioa_ ("Dump #^d", dump.erfno);
350           call write_disk (dump_disk_pvtx, first_dump_record, dumpptr, code); /* hedge against crash */
351           if code ^= 0 then go to dump_partition_error;
352 
353           dump.words_dumped = 0;
354           begin;
355 dcl  kludge_valid                       bit (36) aligned based (addr (dump.valid));
356                kludge_valid = "111111111111111111111111111111111111"b; /* azm expects it */
357           end;
358           dump.time = clock;                                /* fill in header */
359           dump.num_segs = 0;
360           dump.valid_355 = "0"b;
361           dump.dumped_355s = "0"b;
362           dump.time_355 = 0;
363           dump.version = DUMP_VERSION_2;
364 
365 /* save the various toehold information into the header. */
366 
367           dump.dbr = crash_dbr;
368           dump.low_order_port = sys_info$clock_;
369           if examine_crash then do;
370                dump.amptwregs = toehold$.ptwam_regs;
371                dump.amptwptrs = toehold$.ptwam_ptrs;
372                dump.amsdwregs = toehold$.sdwam_regs;
373                dump.amsdwptrs = toehold$.sdwam_ptrs;
374                do hreg = 0 to 15;
375                     dump.ouhist (hreg) = toehold$.ou_history_registers (hreg);
376                     dump.cuhist (hreg) = toehold$.cu_history_registers (hreg);
377                     dump.duhist (hreg) = toehold$.du_history_registers (hreg);
378                     dump.auhist (hreg) = toehold$.apu_history_registers (hreg);
379                end;
380                dump.prs = toehold$.mc_.prs;
381                unspec (dump.regs) = unspec (toehold$.mc_.regs);
382                dump.mctime = bin (toehold$.mc_.fault_time, 54);
383                unspec (dump.scu) = unspec (toehold$.mc_.scu);
384                unspec (dump.mcm) = unspec (toehold$.masks);
385                substr (dump.intrpts, 1, 16) = substr (toehold$.interrupt, 1, 16);
386                substr (dump.intrpts, 17, 16) = substr (toehold$.interrupt, 37, 16);
387                dump.bar = toehold$.bar;
388                dump.modereg = toehold$.mode_reg;
389                dump.cmodereg = toehold$.cache_mode_reg;
390                dump.faultreg = toehold$.mc_.fault_reg;
391                dump.ptrlen = toehold$.mc_.eis_info;
392           end;
393           do scu_tag = lbound (dump.coreblocks.num_first, 1) to hbound (dump.coreblocks.num_first, 1);
394                call rsw_util$port_info (scu_tag, scu_enabled, scu_base, scu_size, scu_interlace);
395                dump.coreblocks.num_first (scu_tag) = bit (scu_base, 18);
396                dump.coreblocks.num_blocks (scu_tag) = bit (scu_size, 18);
397           end;
398 %page;
399           current_dump_record = first_dump_record + 66;     /* 2 for header and 64 for (obsolete) fnp dumping */
400           dseg_no = segno (addr (dseg$));                   /* interesting per-process(or) segments */
401           pds_no = segno (addr (pds$));
402           prds_no = segno (addr (prds$));
403           kst_no = segno (addr (kst_seg$));
404 
405           aptep = addr (my_apte);                           /* ptrs to local copies of things */
406           sdw_info_ptr = addr (my_sdw_info);
407           ptw_info_ptr = addr (my_ptw_info);
408           seg_info_ptr = addr (my_seg_info);
409           astep = addr (my_aste);
410           dp = addr (directory_mod);
411           dump_astep = get_ptrs_$given_segno (segno (addr (dump_seg$)));
412           dump_ptp = addrel (dump_astep, size (aste));
413           dump_astep -> aste.pvtx = dump_disk_pvtx;
414           do page_num = 0 to 255;
415                call ptw_util_$make_null_disk (addrel (dump_ptp, page_num), first_dump_record + page_num); /* safe initial state */
416           end;
417 
418 /* Find range of aptes to dump from tc_data. */
419 
420           tcmp = addr (tc_data$);
421           tc_data_no = segno (addr (tc_data$));
422 
423           call bce_appending_simulation$new_segment (tc_data_no, seg_info_ptr, code);
424           if code ^= 0 then last_apte = 0;
425           else do;
426                if seg_info.paged then do;
427                     call ptw_util_$dissect (addr (seg_info.page_table (0)), ptw_info_ptr);
428                     tc_data_addr = ptw_info.address;
429                end;
430                else tc_data_addr = seg_info.address;
431                call bce_appending_simulation$get_absolute (tc_data_addr + wordno (addr (tcm.apt_size)), 1, addr (last_apte), code);
432                if code ^= 0 then last_apte = 0;
433           end;
434 
435 
436 /* Get sst bounds (for finding sst paged segments). */
437 
438           sst_start = 0; sst_end = -1;
439           call bce_appending_simulation$new_segment (segno (addr (sst_seg$)), seg_info_ptr, code);
440           if code = 0 then do;
441                if seg_info.paged then do;
442                     call ptw_util_$dissect (addr (seg_info.page_table (0)), ptw_info_ptr);
443                     sst_start = ptw_info.address;
444                end;
445                else sst_start = seg_info.address;
446                sst_end = sst_start + seg_info.size - 1;
447           end;
448 
449           processed_crash_dbr = "0"b;
450           dumped_hc_seg (*) = "0"b;
451           sst_bit_map = "0"b;
452 
453           if create_sstnt then call bce_create_sstnt (sst_start, sst_end);
454 %page;
455 
456 /* Walk down through aptes, dumping what the operator wants dumped for each one. */
457 
458 /* We iterate over all aptes in tc_data.  When we find the apte that matches
459 the process that crashed, we set processed_crash_dbr.  Otherwise, this isn't
460 set and we make one more pass (0) which picks this process up. */
461 
462           do apte_num = 1 to last_apte, 0 while (^processed_crash_dbr); /* include dbr in machine conditions */
463                call bce_check_abort;                        /* operator wants to stop? */
464 
465                if apte_num > 0 then do;                     /* else using crash dbr */
466                     call bce_appending_simulation$get_absolute (tc_data_addr + wordno (addr (tcm.apt)) + (apte_num - 1) * size (apte), size (apte), aptep, code);
467                     if code ^= 0 then go to next_apte;
468                     if apte.state = Empty_apte then go to next_apte;
469                     current_dbr = unspec (apte.dbr);
470 
471 /* Find options that apply to this process. */
472 
473                     if dump_options (Running) ^= "0"b & (apte.dbr_loaded | apte.state = Stopped_apte) then proc_options = dump_options (Running);
474                     else if apte.eligible then proc_options = dump_options (Eligible);
475                     else proc_options = dump_options (All);
476                     if apte_num = 1 then proc_options = proc_options | dump_options (Initializer); /* inzr is first apte */
477                end;
478                else do;
479                     current_dbr = crash_dbr;
480                     proc_options = dump_options (Running) | dump_options (Initializer); /* grab all you can */
481                end;
482 
483                call dbr_util_$dissect (addr (current_dbr), dbr_info_ptr);
484                if dbr_info.address = crash_dbr_addr then processed_crash_dbr = "1"b;
485                if proc_options = "0"b then go to next_apte; /* not interesting */
486                substr (proc_options, Hardcore, 1) = "1"b;   /* need to dump these, if any, so that process is
487                                                             visible in dump (a decrease in segnos appears) */
488 
489                call bce_appending_simulation$new_dbr (current_dbr, last_segnum, code);
490                if code ^= 0 then go to next_apte;
491                call bce_appending_simulation$new_segment (dseg_no, addr (dseg_info), code);
492                if code ^= 0 then go to next_apte;
493 
494                call ioa_ ("proc ^o, dbr = ^24.3b", apte_num, current_dbr);
495 %page;
496 
497 /* Process segments desired. */
498 
499                do segnum = 0 to last_segnum;
500                     call bce_check_abort;                   /* last chance for operator to stop */
501 
502 /* optimization - keep around a page of dseg; see if an sdw is faulted before
503 expending new_segment on it */
504 
505                     if mod (segnum, dimension (dseg_buffer, 1)) = 0 then /* crossed into next buffer of sdw's (next dseg page) */
506                          call bce_appending_simulation$get_virtual (addr (dseg_info), segnum * 2, size (dseg_buffer), addr (dseg_buffer), code); /* zero sdw's on error */
507                     seg_sdw_ptr = addr (dseg_buffer (mod (segnum, dimension (dseg_buffer, 1))));
508                     call sdw_util_$dissect (seg_sdw_ptr, sdw_info_ptr);
509                     if sdw_info.faulted then go to next_seg;
510 
511                     call bce_appending_simulation$new_sdw (seg_sdw, seg_info_ptr, code);
512                     if code ^= 0 then go to next_seg;
513 
514 /* See if we should dump this segment. */
515 
516                     if substr (proc_options, Hardcore, 1) then
517                          if segnum = dseg_no | segnum = pds_no | segnum = prds_no | segnum = kst_no then go to dump_seg;
518                     if ^seg_info.write then go to next_seg;
519                     if dbr_info.stack_base_segnum = 0       /* idle or initialization (all segs hc) */
520                          | segnum < dbr_info.stack_base_segnum then /* hc seg */
521                          if segnum > hbound (dumped_hc_seg, 1) then go to dump_seg;
522                          else if ^dumped_hc_seg (segnum) then do;
523                               dumped_hc_seg (segnum) = "1"b;
524                               go to dump_seg;               /* dump for first proc */
525                          end;
526                          else go to next_seg;               /* not for others */
527                     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 */
528                     if ^seg_info.paged then go to dump_seg; /* unpaged non-hardcore - rare */
529                     if sst_start > 0 then do;               /* there was a sst */
530                          if seg_info.address < sst_start | sst_end < seg_info.address then go to dump_seg; /* not sst paged seg - rare for non-hc */
531 
532 /* We now have a non-hardcore standard paged segment. */
533 
534                          if ^substr (proc_options, Writeable, 1) then do; /* if we don't want all writable, segments need some justification */
535                               if seg_info.sst_data.per_process & substr (proc_options, Per_process, 1) then go to consider_seg;
536                               if seg_info.sst_data.dirsw then do;
537                                    if substr (proc_options, Directories, 1) then go to consider_seg;
538                                    if substr (proc_options, Modifying_dirs, 1) then do;
539                                         call bce_appending_simulation$get_virtual (seg_info_ptr, wordno (addr (dir.modify)) - wordno (dp), 1, dp, code);
540                                         if dir.modify then go to consider_seg;
541                                    end;
542                               end;
543                               go to next_seg;
544                          end;
545 consider_seg:
546 
547 /* We want to dump this segment.  First, though, we ask if we dumped it before
548 (we have processed its aste before).  Since no two astes can fit in the same
549 16 words of memory (they are at least 16 words long), we can divide the sst
550 into 16 word blocks.  If two segments claim different (starting) blocks, we
551 say they have different astes and are different segments. */
552 
553                          sst_index = divide (seg_info.address - sst_start + 8, 16, 14) + 1;
554                          if substr (sst_bit_map, sst_index, 1) then go to next_seg; /* already dumped */
555                          substr (sst_bit_map, sst_index, 1) = "1"b;
556                     end;
557                     else go to next_seg;
558 %page;
559 dump_seg:
560 
561 /* Time to dump this segment.  See if it will fit. */
562 
563                     if dump.num_segs = dimension (dump.segs, 1) then do;
564                          call ioa_ ("Segment array overflow.");
565                          go to end_dump;
566                     end;
567                     dump.num_segs = dump.num_segs + 1;
568                     dump.segs.segno (dump.num_segs) = bit (bin (segnum, 18), 18);
569                     dump.segs.length (dump.num_segs) = "0"b;
570 
571 /* Map dump_seg onto next area of dump part. */
572 
573                     num_pages = divide (seg_info.size + 1023, 1024, 8);
574                     if current_dump_record + num_pages > first_dump_record + num_records then do;
575                          call ioa_ ("Dump partition overflow.");
576                          go to end_dump;
577                     end;
578                     do page_num = 0 to num_pages - 1;
579                          call ptw_util_$make_null_disk (addrel (dump_ptp, page_num), current_dump_record + page_num);
580                     end;
581 
582 /* We must find the last non-zero page.  After this, we move it into dump_seg
583 and then page the rest of the segment into there.  We read the segment
584 backwards, for possible i/o latency improvement. */
585 
586                     null_page = "1"b;
587                     do page_num = num_pages - 1 to 0 by -1 while (null_page);
588                          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);
589                          if my_page_buffer ^= "0"b then null_page = "0"b;
590                     end;
591                     if null_page then go to next_seg;       /* empty seg */
592                     page_num = page_num + 1;                /* last non-null page */
593                     addrel (addr (dump_seg$), page_num * 1024) -> page_buffer = my_page_buffer;
594                     if page_num > 0 then
595                          call bce_appending_simulation$get_virtual (seg_info_ptr, 0, min (seg_info.size, page_num * 1024), addr (dump_seg$), code);
596                     call pc$cleanup (dump_astep);           /* write out */
597                     current_dump_record = current_dump_record + page_num + 1;
598                     dump.segs.length (dump.num_segs) = bit (bin ((page_num + 1) * 16, 18), 18);
599                     dump.words_dumped = dump.words_dumped + (page_num + 1) * 1024;
600 next_seg:
601                end;
602 next_apte:
603           end;
604 
605           dump_severity = 0;                                /* all done! */
606 %page;
607 end_dump:
608 
609 /* Write out header */
610 
611           call write_disk (dump_disk_pvtx, first_dump_record + 1, addrel (dumpptr, 1024), code);
612           call write_disk (dump_disk_pvtx, first_dump_record, dumpptr, code);
613           return;
614 %page;
615 severity: entry () returns (fixed bin);
616 
617           return (dump_severity);
618 %page; %include apte;
619 %page; %include bce_appending_seg_info;
620 %page; %include bce_subsystem_info_;
621 %page; %include bos_dump;
622 %page; %include collection_1_phases;
623 %page; %include dbr_info;
624 %page; %include dir_header;
625 %page; %include ptw_info;
626 %page; %include state_equs;
627 %page; %include tcm;
628 %page; %include hc_lock;
629 %page; %include toe_hold;
630      end;