1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  7    *                                                         *
  8    *********************************************************** */
  9 
 10 
 11 flush:    proc;
 12 
 13 /* Program to flush the contents of main memory by touching a
 14    sufficient number of pages in temporary segments created for
 15    this purpose.  The number of pages to flush is determined
 16    from sst$nused (it defaults to 1024 is the user does not
 17    have sufficient access to examine sst$nused).  The temporary
 18    segments are named flush.<sequential number>, and they are
 19    created either in thr process directory (the default) or in
 20    a directory supplied by the user via the -temp_dir control
 21    argument.  In order for all pages of main memory to be flushed,
 22    the directory used must have sufficient quota (the aggregate
 23    quota used by the temporary segments is the value of sst$nused).
 24    There is a mildly interesting hack to prevent a fatal process
 25    error if the temporary directory is the process directory and
 26    there is not enough quota to flush all of main memory.
 27    Prior to the flush, the next page of the stack is written to,
 28    ensuring that there's enough stack to do the minimal condition
 29    handling if a reqord quota overflow occurs.
 30 
 31    Completely rewritten by J. Bongiovanni in June 1981                                                        */
 32 
 33 
 34 /* Automatic */
 35 
 36           dcl arg_no fixed bin;                             /* current argument number                        */
 37           dcl argl fixed bin (21);                          /* length of current argument                     */
 38           dcl argp ptr;                                     /* pointer to current argument                    */
 39           dcl code fixed bin (35);                          /* standard error code                            */
 40           dcl dir_name char (168);                          /* name of directory for temp segments            */
 41           dcl flush_seg_no pic "zzzz9";                     /* for constructing temp segment names            */
 42           dcl garbage fixed bin (35);                       /* just what it says                              */
 43           dcl n_args fixed bin;                             /* number of arguments                            */
 44           dcl n_flush_segs fixed bin;                       /* number of temporary segs                       */
 45           dcl n_pages fixed bin;                            /* number of pages in memory to flush             */
 46           dcl n_pages_flushed fixed bin;                    /* count of pages flushed                         */
 47           dcl n_pages_left fixed bin;                       /* used in creating temp segs                     */
 48           dcl other_error bit (1);                          /* ON => seg_fault_error occurred during flush    */
 49           dcl pages_per_seg fixed bin;                      /* number of pages per segment                    */
 50           dcl pagex fixed bin;                              /* index to array of pages                        */
 51           dcl quota_overflow bit (1);                       /* ON => RQO occurred during flush                */
 52           dcl segx fixed bin;                               /* index into control structure                   */
 53           dcl tempp ptr;                                    /* pointer to temp seg                            */
 54 
 55 /* Static */
 56 
 57           dcl DEFAULT_PAGES_TO_FLUSH fixed bin int static options (constant) init (1024);
 58           dcl MYNAME char (5) int static options (constant) init ("flush");
 59           dcl TEMP_SEG_PREFIX char (6) int static options (constant) init ("flush.");
 60 
 61 /* Based */
 62 
 63           dcl arg char (argl) based (argp);                 /* current argument                               */
 64           dcl 1 flush_segs aligned based (tempp),           /* control structure                              */
 65           2 n_segs fixed bin,                               /* number of temp segs                            */
 66           2 segs (0 refer (n_segs)),
 67           3 segp ptr,                                       /* pointer to segment                             */
 68           3 seg_pages fixed bin;                            /* number of pages to touch in this seg           */
 69           dcl 1 segment aligned based,                      /* used for touching pages during flush           */
 70           2 page (256),
 71           3 word (1024) fixed bin (35);
 72 
 73 /* Entry */
 74 
 75           dcl absolute_pathname_ entry (char(*), char(*), fixed bin(35));
 76           dcl com_err_ entry options (variable);
 77           dcl cu_$arg_count entry (fixed bin, fixed bin(35));
 78           dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
 79           dcl get_pdir_ entry() returns(char(168));
 80           dcl get_temp_segment_ entry (char(*), ptr, fixed bin(35));
 81           dcl hcs_$delentry_seg entry (ptr, fixed bin(35));
 82           dcl hcs_$make_seg entry (char(*), char(*), char(*), fixed bin(5), ptr, fixed bin(35));
 83           dcl ioa_$ioa_switch entry options (variable);
 84           dcl release_temp_segment_ entry (char(*), ptr, fixed bin(35));
 85           dcl ring_zero_peek_$by_definition entry (char(*), char(*), fixed bin(18), ptr, fixed bin(19), fixed bin(35));
 86 
 87 /* External */
 88 
 89           dcl error_table_$badopt fixed bin (35) external;
 90           dcl iox_$error_output ptr external;
 91           dcl sys_info$max_seg_size fixed bin (19) external;
 92           dcl sys_info$page_size fixed bin external;
 93 
 94 /* Condition */
 95 
 96           dcl cleanup condition;
 97           dcl record_quota_overflow condition;
 98           dcl seg_fault_error condition;
 99 
100 /* Builtin */
101 
102           dcl addr builtin;
103           dcl ltrim builtin;
104           dcl null builtin;
105           dcl stackframeptr builtin;
106           %page;
107 
108 /* Pick up arguments and validate                                                                             */
109 
110           dir_name = get_pdir_ ();                          /* default temp dir = [pd]                        */
111 
112           call cu_$arg_count (n_args, code);
113           if code ^= 0 then do;                             /* active function not allowed                    */
114                call com_err_ (code, MYNAME);
115                return;
116           end;
117 
118           do arg_no = 1 to n_args;
119                call cu_$arg_ptr (arg_no, argp, argl, code);
120                if arg = "-temp_dir" | arg = "-td" then do;
121                     arg_no = arg_no + 1;
122                     call cu_$arg_ptr (arg_no, argp, argl, code);
123                     if code^= 0 then do;
124                          call com_err_ (code, MYNAME, "Temp directory name");
125                          return;
126                     end;
127                     call absolute_pathname_ (arg, dir_name, code);
128                     if code ^= 0 then do;
129                          call com_err_ (code, MYNAME, arg);
130                          return;
131                     end;
132                end;
133                else do;
134                     call com_err_ (error_table_$badopt, MYNAME, arg);
135                     return;
136                end;
137           end;
138           %page;
139 
140 /* Get a temp segment for the control structure.  Find out how many pages
141    we should flush, and create the temporary segments needed in the
142    appropriate directory                                                                                      */
143 
144           tempp = null ();
145           on cleanup call clean_out;
146 
147           call get_temp_segment_ (MYNAME, tempp, code);
148           if code ^= 0 then do;
149                call com_err_ (code, MYNAME, "Getting temp segment");
150                call clean_out;
151                return;
152           end;
153 
154           call ring_zero_peek_$by_definition ("sst", "nused", 0, addr (n_pages), 1, code);
155           if code ^= 0 then
156                n_pages = DEFAULT_PAGES_TO_FLUSH;
157 
158           pages_per_seg = divide (sys_info$max_seg_size, sys_info$page_size, 17);
159           n_flush_segs = divide (n_pages, pages_per_seg, 17);
160           n_pages_left = n_pages;
161           do segx = 1 to n_flush_segs;
162                flush_seg_no = segx;
163                call hcs_$make_seg (dir_name, TEMP_SEG_PREFIX || ltrim (flush_seg_no), "",
164                     01010b, flush_segs.segs (segx).segp, code);
165                if flush_segs.segs (segx).segp = null () then do;
166                     call com_err_ (code, MYNAME, "Creating ^[>^1s^;^a>^]^a",
167                          (dir_name = ">"), dir_name, TEMP_SEG_PREFIX || ltrim (flush_seg_no));
168                     call clean_out;
169                     return;
170                end;
171                flush_segs.segs (segx).seg_pages = min (pages_per_seg, n_pages_left);
172                flush_segs.n_segs = segx;
173                n_pages_left = n_pages_left - flush_segs.segs (segx).seg_pages;
174           end;
175           %page;
176 
177 /* Do the flush, after making sure there's enough stack to handle a
178    record_quota_overflow condition                                                                            */
179 
180           stackframeptr () -> segment.page (2).word (1) = 1;
181           quota_overflow = "0"b;
182           other_error = "0"b;
183 
184           on record_quota_overflow begin;
185                quota_overflow = "1"b;
186                goto END_FLUSH;
187           end;
188 
189           on seg_fault_error begin;                         /* most likely out of room on LV */
190                other_error = "1"b;
191                goto END_FLUSH;
192           end;
193 
194           n_pages_flushed = 0;
195 
196           do segx = 1 to n_flush_segs;
197                do pagex = 1 to flush_segs.segs (segx).seg_pages;
198                     garbage = flush_segs.segs (segx).segp -> segment.page (pagex).word (1);
199                     n_pages_flushed = n_pages_flushed + 1;
200                end;
201           end;
202 
203 END_FLUSH:
204           revert record_quota_overflow;
205           call clean_out;
206 
207           if quota_overflow then
208                call ioa_$ioa_switch (iox_$error_output,
209                "Insufficient quota for full flush - flushed ^d out of ^d pages",
210                n_pages_flushed, n_pages);
211 
212           if other_error then
213                call ioa_$ioa_switch (iox_$error_output,
214                "Error during flush - flushed ^d out of ^d pages",
215                n_pages_flushed, n_pages);
216 
217           return;
218           %page;
219 
220 /* Internal procedure to clean up after ourselves                                                             */
221 
222 clean_out:
223           proc;
224 
225           if tempp ^= null () then do;
226                do segx = 1 to flush_segs.n_segs;
227                     call hcs_$delentry_seg (flush_segs.segs (segx).segp, code);
228                end;
229                call release_temp_segment_ (MYNAME, tempp, code);
230                tempp = null ();
231           end;
232 
233 end clean_out;
234 
235 
236 end flush;