1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1987                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1983 *
  6         *                                                         *
  7         *********************************************************** */
  8 /* format: style4 */
  9 /* 82-12-13 hewn from raw bits by E. N. Kittlitz */
 10 /* 84-11-05 renamed terminate_ to makeunknown_ by Keith Loepere */
 11 
 12 kst_util: proc;
 13 
 14 dcl  a_segno fixed bin (17);                                /* first segment number in range/allocated (input/output) */
 15 dcl  a_count fixed bin (17);                                /* number of segments required */
 16 dcl  a_code fixed bin (35);                                 /* status code */
 17 dcl  a_kstep ptr;                                           /* pointer to kste */
 18 dcl  a_new_sw bit (2) aligned;                              /* set_256K_switch input */
 19 dcl  a_old_sw bit (2) aligned;                              /* set_256K_switch output */
 20 
 21 dcl  code fixed bin (35);
 22 dcl  collected fixed bin;                                   /* count of KSTEs grabbed during a GC */
 23 dcl  count fixed bin;                                       /* copy of a_count */
 24 dcl  first_segno fixed bin;                                 /* first segno assigned */
 25 dcl  free_range_trip fixed bin;                             /* scanning segnos or actually freeing them */
 26 dcl  headp ptr;                                             /* pointer to KSTE list head */
 27 dcl  last_segno fixed bin;                                  /* last segno assigned */
 28 dcl  level fixed bin (3);
 29 dcl  new_sw bit (2) aligned;
 30 dcl  rel_kstep bit (18) aligned;
 31 dcl  run fixed bin;
 32 dcl  segno fixed bin;                                       /* temporary index */
 33 dcl  tries fixed bin;
 34 
 35 dcl  head bit (18) unaligned based (headp);                 /* head of KSTE list */
 36 
 37 dcl  level$get entry returns (fixed bin (3));
 38 dcl  makeunknown_ entry (fixed bin, bit (36) aligned, bit (1) aligned, fixed bin (35));
 39 dcl  setfaults$if_256K entry (fixed bin);
 40 
 41 dcl  error_table_$action_not_performed fixed bin (35) ext static;
 42 dcl  error_table_$bad_arg fixed bin (35) ext static;
 43 dcl  error_table_$invalidsegno fixed bin (35) ext static;
 44 dcl  error_table_$nrmkst fixed bin (35) ext static;
 45 dcl  error_table_$segno_in_use fixed bin (35) ext static;
 46 
 47 dcl  pds$initial_ring fixed bin (3) static external;
 48 
 49 dcl  N_STACKS fixed bin init (8) static options (constant);
 50 
 51 dcl  (addr, baseno, binary, copy, dim, fixed, index, min, mod, null, ptr, rel, reverse, substr, unspec) builtin;
 52 
 53           return;                                           /* there is no kst_util */
 54 %page;
 55 /* free_range: put all the specified segnos back on the free list. They must ALL be reserved segnos */
 56 
 57 free_range: entry (a_segno, a_count, a_code);
 58 
 59           kstp = pds$kstp;
 60           first_segno = a_segno;
 61           count = a_count;
 62           if count < 1 then
 63                call abort (error_table_$bad_arg);
 64           last_segno = first_segno + count - 1;
 65           level = level$get ();
 66           if first_segno - kst.lowseg < level |             /* lower ring stack or hardcore */
 67                last_segno > kst.highest_used_segno then     /* too big */
 68                call abort (error_table_$invalidsegno);
 69           do free_range_trip = 1 to 2;
 70                do segno = first_segno to last_segno;        /* check the whole bunch */
 71                     kstep = addr (kst.kst_entry (segno));
 72                     if kste.fp ^= "777777"b3 |              /* this should never happen on second trip, but let's be sure */
 73                          unspec (kste.entryp) ^= ""b then
 74                          call abort (error_table_$action_not_performed);
 75                     if free_range_trip = 2 then do;
 76                          kste.fp = kst.free_list;
 77                          kst.free_list = rel (kstep);
 78                     end;
 79                end;
 80           end;
 81           a_code = 0;
 82           return;
 83 
 84 %page;
 85 /* garbage_collect: tidy up process address space by terminating directory segments
 86    that have no known inferiors, or segments not known in any ring */
 87 
 88 garbage_collect: entry (a_code);
 89 
 90           kstp = pds$kstp;
 91           collected = 0;
 92           do segno = kst.lowseg + N_STACKS to kst.highest_used_segno;
 93                call try_to_remove (segno, segno);           /* out, damn' spot */
 94           end;
 95           kst.garbage_collections = kst.garbage_collections + 1;
 96           if collected > 0 then do;
 97                kst.entries_collected = kst.entries_collected + collected;
 98                a_code = 0;
 99           end;
100           else a_code = error_table_$nrmkst;
101           return;
102 %page;
103 /* get_range: reserve from 1 to the largest conceivable number of consecutive
104    segment numbers. */
105 
106 get_range: entry (a_count, a_segno, a_code);
107 
108           kstp = pds$kstp;                                  /* setup */
109           count = a_count;                                  /* copy argument */
110           if count < 1 then                                 /* tsk tsk */
111                call abort (error_table_$bad_arg);
112           code, run = 0;
113           do tries = 1 to 2 while (code = 0 & run < count); /* up to two tries */
114                first_segno = -1;
115                do segno = kst.lowseg + N_STACKS to kst.highest_used_segno while (run < count);
116                     kstep = addr (kst.kst_entry (segno));
117                     if unspec (kste.entryp) ^= ""b |
118                          kste.fp = "777777"b3 then do;      /* forget it */
119                          first_segno = -1;
120                          run = 0;
121                     end;
122                     else if first_segno < 0 then do;        /* starting a group */
123                          first_segno = segno;
124                          run = 1;
125                     end;
126                     else run = run + 1;                     /* got a streak going */
127                end;                                         /* perusal of kst */
128                if first_segno < 0 then                      /* try for space at end */
129                     first_segno = kst.highest_used_segno + 1;
130                last_segno = first_segno + count - 1;        /* just how far would we go? */
131                if run < count & tries = 1 then              /* don't have a free range yet */
132                     if last_segno <= kst.highseg then       /* we can fit at the top */
133                          run = count;                       /* blast out of loop */
134                     else call garbage_collect (code);       /* desperation measures */
135           end;
136           if last_segno > kst.highseg then                  /* no space */
137                call abort (error_table_$nrmkst);
138           if last_segno > kst.highest_used_segno then       /* expand! */
139                call initialize_region (last_segno);
140 
141           do segno = first_segno to last_segno;             /* now get the segment numbers off the free list */
142                kstep = addr (kst.kst_entry (segno));
143                call unthread_kste (kstep);                  /* off the free list */
144                kste.fp = "777777"b3;                        /* and now it's reserved */
145           end;
146 
147           a_segno = first_segno;                            /* why not tell the fella */
148           a_code = 0;
149 
150 RETURN:   return;
151 %page;
152 /* initialize_region: expand kst up through segment a_segno */
153 
154 initialize_region: entry (a_segno);
155           kstp = pds$kstp;
156           last_segno = a_segno;
157           do segno = kst.highest_used_segno + 1 to last_segno; /* initialize any new kstes and thread on free list */
158                kstep = addr (kst.kst_entry (segno));
159                kste.segno = segno;
160                unspec (kste.entryp) = "0"b;
161                kste.fp = kst.free_list;
162                kst.free_list = rel (kstep);
163                kst.highest_used_segno = segno;
164           end;
165           return;
166 
167 %page;
168 /* set_256K_switch controls the use of 256K segments. if the KST switch is "1"b, you can
169    talk to them. Otherwise, the limit is sys_info$max_seg_size, buster. */
170 
171 set_256K_switch: entry (a_new_sw, a_old_sw, a_code);
172 
173           kstp = pds$kstp;
174           new_sw = a_new_sw;
175           a_old_sw = "1"b || kst.allow_256K_connect;        /* indicate old value valid */
176           if substr (new_sw, 1, 1) ^= "1"b then             /* first bit not set, do nothing */
177                call abort (error_table_$action_not_performed);
178           level = level$get ();
179           if level > pds$initial_ring then
180                call abort (error_table_$action_not_performed);
181           if substr (new_sw, 2, 1) = "1"b then
182                kst.allow_256K_connect = "1"b;
183           else if kst.allow_256K_connect then do;           /* must disconnect existing 256K items */
184                kst.allow_256K_connect = "0"b;
185                do segno = kst.lowseg to kst.highest_used_segno;
186                     call setfaults$if_256K (segno);
187                end;
188           end;
189           a_code = 0;
190           return;
191 %page;
192 /* Unthread_kste removes a  kste  from  the  list  on   which   it   is  threaded.
193    If kste.entryp = 0 then the kste is assumed to be threaded onto the free list.
194    Otherwise, the kste is assumed to be threaded onto a hash class list. */
195 
196 unthread_kste: entry (a_kstep);
197           kstp = pds$kstp;
198           if a_kstep -> kste.fp = "777777"b3 then
199                return;
200           if unspec (a_kstep -> kste.entryp) = "0"b then
201                headp = addr (kst.free_list);
202           else headp = addr (kst.uid_hash_bucket (mod (fixed (a_kstep -> kste.uid), dim (kst.uid_hash_bucket, 1))));
203 
204           rel_kstep = rel (a_kstep);
205           if head = rel_kstep
206           then head = a_kstep -> kste.fp;
207           else do kstep = ptr (a_kstep, head) repeat (ptr (kstep, kste.fp)) while (rel (kstep) ^= "0"b);
208                if kste.fp = rel_kstep then do;
209                     kste.fp = a_kstep -> kste.fp;
210                     return;
211                end;
212           end;
213           return;
214 %page;
215 /* INTERNAL PROCEDURES */
216 
217 abort: proc (abort_code);                                   /* the prefered punter */
218 dcl  abort_code fixed bin (35);
219 
220           a_code = abort_code;
221           go to RETURN;
222      end abort;
223 
224 
225 try_to_remove: proc (rsegno, tsegno);
226 dcl  rsegno fixed bin;                                      /* segno to attempt to remove */
227 dcl  tsegno fixed bin;                                      /* highest segno caller has attemted to remove */
228 
229 dcl  code fixed bin (35);
230 dcl  psegno fixed bin;
231 dcl  entryp ptr;
232 dcl  lkstep ptr;
233 dcl  1 lkste aligned like kste based (lkstep);
234 
235           lkstep = addr (kst.kst_entry (rsegno));
236           if unspec (lkste.usage_count) ^= ""b then return; /* known in some ring */
237           if unspec (lkste.entryp) = ""b then return;
238           entryp = lkste.entryp;
239           call makeunknown_ (rsegno, "0"b, ("0"b), code);
240           if code ^= 0 then return;
241           collected = collected + 1;                        /* count it */
242           if entryp ^= null then do;
243                psegno = binary (baseno (entryp));
244                if psegno < tsegno then                      /* caller has already 'seen' our parent, so we must attack it */
245                     call try_to_remove (psegno, tsegno);
246           end;
247           return;
248      end try_to_remove;
249 
250 %page;
251 %include aste;
252 %page;
253 %include kst;
254 
255 
256      end kst_util;