1
2
3
4
5
6
7
8
9
10
11 flush: proc;
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36 dcl arg_no fixed bin;
37 dcl argl fixed bin (21);
38 dcl argp ptr;
39 dcl code fixed bin (35);
40 dcl dir_name char (168);
41 dcl flush_seg_no pic "zzzz9";
42 dcl garbage fixed bin (35);
43 dcl n_args fixed bin;
44 dcl n_flush_segs fixed bin;
45 dcl n_pages fixed bin;
46 dcl n_pages_flushed fixed bin;
47 dcl n_pages_left fixed bin;
48 dcl other_error bit (1);
49 dcl pages_per_seg fixed bin;
50 dcl pagex fixed bin;
51 dcl quota_overflow bit (1);
52 dcl segx fixed bin;
53 dcl tempp ptr;
54
55
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
62
63 dcl arg char (argl) based (argp);
64 dcl 1 flush_segs aligned based (tempp),
65 2 n_segs fixed bin,
66 2 segs (0 refer (n_segs)),
67 3 segp ptr,
68 3 seg_pages fixed bin;
69 dcl 1 segment aligned based,
70 2 page (256),
71 3 word (1024) fixed bin (35);
72
73
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
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
95
96 dcl cleanup condition;
97 dcl record_quota_overflow condition;
98 dcl seg_fault_error condition;
99
100
101
102 dcl addr builtin;
103 dcl ltrim builtin;
104 dcl null builtin;
105 dcl stackframeptr builtin;
106 %page;
107
108
109
110 dir_name = get_pdir_ ();
111
112 call cu_$arg_count (n_args, code);
113 if code ^= 0 then do;
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
141
142
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
178
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;
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
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;