1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1987                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         * Copyright (c) 1972 by Massachusetts Institute of        *
  8         * Technology and Honeywell Information Systems, Inc.      *
  9         *                                                         *
 10         *********************************************************** */
 11 
 12 
 13 
 14 /****^  HISTORY COMMENTS:
 15   1) change(86-06-24,DGHowe), approve(86-06-24,MCR7396),
 16      audit(86-08-01,Schroth), install(86-11-20,MR12.0-1222):
 17      initialize the heap_header_ptr to null in get_initial_linkage.
 18   2) change(86-10-01,Fawcett), approve(86-10-01,MCR7473),
 19      audit(86-10-22,Farley), install(86-11-03,MR12.0-1206):
 20      Changed to eliminate stack_header.old_lot_ptr, this obsolete ptr was
 21      replaced by stack_header.cpm_data_ptr for Control Point Management.
 22                                                    END HISTORY COMMENTS */
 23 
 24 /* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */
 25 link_man$other_linkage:
 26      proc (atxp, alp, astp, asymbp, acode);
 27 
 28 /* LINK_MAN
 29    "
 30 
 31    This program is the utility program used by the Multics ring 0 linker.
 32 
 33 
 34    Last modified (date and reason):
 35 
 36    9/20/74 by S.Webber Complete rewrite from an earlier version as part
 37    of combining stacks, lots, and clr's.
 38 
 39    rewritten 8/76 by M. Weaver to turn linkage regions into areas.
 40    modified 4/77 by M. Weaver to add entry combine_linkage for lot_fault_handler_
 41    modified 5/77 by M. Weaver to process perprocess_static bit
 42    modified 9/77 by M. Weaver to change assign_linkage to use assign_linkage_ptr
 43    modified 2/78 by M. Weaver to grow lot at correct boundary
 44    Modified April 1981 by J. Bongiovanni to fix recursive grow_lot bug
 45    Modified May, 1981, Charlie Hornig, to convert for ADP SDW formats
 46    Modified August 1981, E. N. Kittlitz per S. Harris (UNCA), check lot size in getlp
 47    Modified 83-12-08 BIM to flush support for .link segments, once and for all.
 48    Modified April 10, 1984 by M. Weaver to check ring arg in $combine_linkage
 49    Modified 84-07-02 BIM to check ring arg in grow_lot.
 50    Modified 85-01-22 Keith Loepere to increment usage count for segment in
 51    target ring when its linkage is combined.
 52 */
 53 
 54 /* Parameters */
 55 
 56 dcl  acode fixed bin (35);
 57 dcl  alp ptr;
 58 dcl  aring fixed bin;
 59 dcl  astp ptr;
 60 dcl  asymbp ptr;
 61 dcl  atxp ptr;
 62 
 63 /* Automatic */
 64 
 65 dcl  1 ainfo aligned like area_info;
 66 dcl  cl fixed bin (14);
 67 dcl  cl_sw bit (1) aligned;
 68 dcl  code fixed bin (35);
 69 dcl  count fixed bin (24);
 70 dcl  dummy bit (36) aligned;
 71 dcl  lp ptr;
 72 dcl  nwords fixed bin (18);
 73 dcl  1 oi like object_info;
 74 dcl  ring fixed bin;
 75 dcl  rings (3) fixed bin;
 76 dcl  1 sdwi aligned like sdw_info;
 77 dcl  sp ptr;
 78 dcl  stack_end fixed bin (18);
 79 dcl  stp ptr;
 80 dcl  target fixed bin;
 81 dcl  target_sp ptr;
 82 dcl  tcode fixed bin (35);
 83 dcl  txp ptr;
 84 dcl  type fixed bin (2);
 85 
 86 /* Entries */
 87 
 88 dcl  define_area_ entry (ptr, fixed bin (35));
 89 dcl  level$get entry returns (fixed bin);
 90 dcl  makestack entry (fixed bin);
 91 dcl  object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35));
 92 dcl  sdw_util_$dissect entry (ptr, ptr);
 93 dcl  segno_usage$increment_other_ring entry (fixed bin, fixed bin, fixed bin (35));
 94 dcl  status_$mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
 95 dcl  terminate_proc entry (fixed bin (35));
 96 
 97 /* External */
 98 
 99 dcl  dseg$ (0:1) fixed bin (71) ext;
100 dcl  error_table_$bad_segment fixed bin (35) ext;
101 dcl  error_table_$badringno fixed bin (35) ext;
102 dcl  error_table_$invalidsegno fixed bin (35) ext;
103 dcl  error_table_$no_linkage fixed bin (35) ext;
104 dcl  error_table_$noalloc fixed bin (35) ext;
105 dcl  error_table_$nrmkst fixed bin (35) ext;
106 dcl  error_table_$termination_requested fixed bin (35) ext;
107 dcl  pds$clr_stack_size (0:7) fixed bin (18) ext;
108 dcl  pds$lot_stack_size (0:7) fixed bin (17) ext;
109 dcl  pds$max_lot_size (0:7) fixed bin (17) ext;
110 dcl  pds$stacks (0:7) ptr ext;
111 dcl  sys_info$max_seg_size ext fixed bin (19);
112 
113 /* Builtins */
114 
115 dcl  (addr, addrel, baseno, bin, bit, divide, max, mod, null, ptr, size, segno, string, substr, wordno) builtin;
116 
117 /* Conditions */
118 
119 dcl  area condition;
120 dcl  cleanup condition;
121 
122 /* Based */
123 
124 dcl  based_area area (100) based;
125 dcl  based_array (nwords) bit (36) aligned based;
126 dcl  based_ptr ptr based;
127 dcl  based_word fixed bin based;
128 dcl  linkage_section (oi.llng) bit (36) aligned based;
129 dcl  static_section (oi.ilng) bit (36) aligned based;
130 %page;
131 /* EXECUTION OF LINK_MAN$OTHER_LINKAGE BEGINS HERE */
132 
133           cl_sw = "0"b;
134           acode = 0;
135           txp = atxp;
136           alp = null;
137           astp = null;
138           asymbp = null;
139 
140           ring = level$get ();
141 
142 /* Now get the target ring of the linkage fault, i.e. the ring in which
143    the snapped link will be relevant */
144 
145 /* The following  sequence of code (through the reference to sdw.r3) should be
146    replaced by a call to fs_get$brackets when that entry becomes efficient */
147 
148 retry:
149           code = txp -> based_word;                         /* touch the segment to make SDW valid */
150           call sdw_util_$dissect (addr (dseg$ (segno (txp))), addr (sdwi));
151           if sdwi.faulted
152           then                                              /* try again */
153                goto retry;
154 
155           cl = sdwi.gate_entry_bound + 1;                   /* get offset of linkage pointer in ring zero gates */
156           rings (1) = bin (sdwi.r1, 3);                     /* copy ring numbers */
157           rings (2) = bin (sdwi.r2, 3);
158           rings (3) = bin (sdwi.r3, 3);
159 
160           if ring < rings (1)
161           then target = rings (1);                          /* calculate target ring ... */
162           else if ring > rings (2)
163                then target = rings (2);
164                else target = ring;
165 
166           if target = 0 then do;                            /* snapping a link to hardcore gate */
167                alp = ptr (txp, cl + mod (cl, 2)) -> based_ptr;
168                                                             /* fetch linkage pointer from text */
169                return;                                      /* that's all for hardcore gates */
170                end;
171 
172           target_sp = get_sp (target);
173 
174           lp = null;
175           call getlp (target_sp, txp, lp, stp);
176           if lp ^= null then do;                            /* yes, just return */
177 ret:
178                alp = lp;
179                astp = stp;
180                asymbp = lp -> header.symbol_ptr;
181                addr (alp) -> its_unsigned.ringno = target;  /* So we can link to gates */
182                return;
183                end;
184 cl_join:
185           call status_$mins (txp, type, count, code);       /* get bit count for object info call */
186           if code ^= 0 then goto error;
187 
188           code = error_table_$bad_segment;
189           oi.version_number = object_info_version_2;        /* set version number of structure */
190           oi.symbp = null;                                  /* in case object_info_ doesn't fill it in */
191           if count > 0 then call object_info_$brief (txp, count, addr (oi), code);
192           if code = error_table_$bad_segment then do;       /* all format flags are turned off */
193                acode = error_table_$no_linkage;
194                return;
195                end;
196           else if code ^= 0 then do;
197 error:
198                     acode = code;
199                     return;
200                     end;
201 
202           tcode = 1;
203 
204           if oi.linkp -> its.its_mod = "100011"b
205           then lp, stp = oi.linkp;                          /* .link segment; pre-initialized when created */
206 
207           else do;
208                on area call terminate_proc (error_table_$noalloc);
209                allocate linkage_section in (target_sp -> stack_header.clr_ptr -> based_area) set (lp);
210                dummy = lp -> linkage_section (oi.llng);     /* avoid bounds fault during EIS copy */
211                lp -> linkage_section = oi.linkp -> linkage_section;
212                lp -> header.original_linkage_ptr = oi.linkp;
213 
214                if lp -> virgin_linkage_header.first_ref_relp
215                then lp -> virgin_linkage_header.first_ref_relp = "000000000001000000"b;
216                                                             /* replace offset with flag */
217 
218                if oi.separate_static then do;               /* must copy static separately */
219                     lp -> header.stats.static_length = bit (bin (oi.ilng, 18), 18);
220                     allocate static_section in (target_sp -> stack_header.combined_stat_ptr -> based_area) set (stp);
221                     dummy = stp -> static_section (oi.ilng);/* avoid bounds fault during EIS copy */
222                     stp -> static_section = oi.statp -> static_section;
223                     end;
224                else do;                                     /* combined static already copied */
225                     lp -> header.stats.static_length =
226                          bit (bin (bin (lp -> header.stats.begin_links, 18) - size (header), 18), 18);
227                                                             /* static section is between header & first link */
228                     stp = lp;
229                     end;
230                lp -> header.stats.segment_number = baseno (txp);
231                lp -> header.symbol_ptr = oi.symbp;
232                end;
233 
234           call setlp (txp, lp, stp, target);
235           substr (lp -> its.pad2, 9, 1) = oi.perprocess_static;
236                                                             /* set flag in 1st word of def_ptr for run unit manager */
237           if cl_sw then return;                             /* no output arguments for this entry */
238           goto ret;
239 %page;
240 combine_linkage:
241      entry (atxp, aring, acode);
242 
243 /* This entry is available through hcs_ and is intended for the lot_fault handler */
244 
245           cl_sw = "1"b;
246           txp = atxp;
247           target = aring;
248           if target ^= level$get () then do;                /* caller must set level to correct ring */
249                acode = error_table_$badringno;
250                return;
251                end;
252           target_sp = get_sp (target);
253           acode = 0;
254           lp = null;
255 
256           goto cl_join;
257 %page;
258 own_linkage:
259      entry (atxp, alp, astp, asymbp, acode);
260 
261 /* Entry to return information about a segment and its linkage which has
262    been set up earlier in the process */
263 
264           acode = 0;
265           txp = atxp;
266           alp, astp, asymbp = null;
267 
268           ring = level$get ();
269           sb = get_sp (ring);
270           call getlp (sb, txp, lp, stp);
271           if lp = null then do;
272                acode = error_table_$no_linkage;
273                return;
274                end;
275           ;
276           alp = lp;
277           astp = stp;
278           asymbp = lp -> header.symbol_ptr;
279           return;
280 %page;
281 /* SET_LP
282    "
283 */
284 
285 set_lp:
286      entry (atxp, alp);
287 
288 /* This entry is obsolete. It is used by the trap-before-link stuff, however, and must be supported.
289    The callers of the entry must assume that no separate static will be allocated, hence, the
290    static pointer passed to setlp is the same as the linkage pointer. */
291 
292           ring = level$get ();
293           call setlp (atxp, alp, alp, ring);
294           return;
295 %page;
296 /* GET_LP
297    "
298 */
299 
300 get_lp:
301      entry (atxp, alp);                                     /* OBSOLETE */
302 
303           ring = level$get ();                              /* get caller's validation level */
304           sb = get_sp (ring);
305           call getlp (sb, atxp, alp, (null));
306           return;
307 %page;
308 /* ASSIGN_LINKAGE
309    "
310 */
311 
312 assign_linkage:
313      entry (aamount, rp, rcode);
314 
315 dcl  aamount fixed bin (18);
316 dcl  rcode fixed bin (35);
317 dcl  rp ptr;
318 
319           rcode = 0;
320           rp = null;
321 
322           on area go to a_l_error;
323 
324           sb = get_sp ((level$get ()));
325           nwords = aamount;
326           allocate based_array in (sb -> stack_header.assign_linkage_ptr -> based_area) set (rp);
327                                                             /* must go in same seg as ipc static */
328 
329           return;
330 
331 a_l_error:
332           rcode = error_table_$noalloc;
333           return;
334 %page;
335 /* GET_INITIAL_LINKAGE
336    "
337 */
338 
339 get_initial_linkage:
340      entry (aring);
341 
342 /* This entry is called only by makestack when a new ring is being created. The program makestack
343    may have been called by link_man. */
344 
345           sp = pds$stacks (aring);
346           stack_end = wordno (sp -> stack_header.stack_end_ptr);
347 
348 /* allocate space for lot in stack */
349 
350           nwords = pds$lot_stack_size (aring);
351           if nwords = 0 then nwords = 512;                  /* force 512 word lot in stack */
352           lotp = sp;                                        /* unused part of lot overlays stack header */
353           sp -> stack_header.cur_lot_size = nwords;
354           stack_end = max (stack_end, nwords * 2);          /* the "2"  is for isot as well as lot */
355           stack_end = divide (stack_end + 15, 16, 17, 0) * 16;
356                                                             /* round up */
357 
358 /* set up linkage section area */
359 
360           if pds$clr_stack_size (aring) > 0 then do;        /* initial area is in stack */
361                ainfo.size = pds$clr_stack_size (aring);
362                ainfo.areap = ptr (sp, stack_end);
363                stack_end = stack_end + ainfo.size;          /* update length of stack */
364                stack_end = divide (stack_end + 15, 16, 17, 0) * 16;
365                                                             /* round up */
366                end;
367           else do;                                          /* clr is to go into separate seg */
368                ainfo.size = sys_info$max_seg_size;
369                ainfo.areap = null;
370                end;
371 
372           ainfo.version = area_info_version_1;
373           string (ainfo.control) = "0"b;
374           ainfo.control.extend = "1"b;
375           ainfo.control.zero_on_free = "1"b;
376           ainfo.control.system = "1"b;
377           ainfo.owner = "linker";
378           call define_area_ (addr (ainfo), code);
379           if code ^= 0 then call terminate_proc (error_table_$termination_requested);
380 
381           sp -> stack_header.max_lot_size = pds$max_lot_size (aring);
382           sp -> stack_header.stack_end_ptr = ptr (sp, stack_end);
383           sp -> stack_header.stack_begin_ptr = ptr (sp, stack_end);
384           sp -> stack_header.lot_ptr = lotp;
385           sp -> stack_header.isot_ptr = addrel (lotp, sp -> stack_header.cur_lot_size);
386           sp -> stack_header.sct_ptr = addrel (lotp, sp -> stack_header.cur_lot_size);
387           sp -> stack_header.system_free_ptr, sp -> stack_header.user_free_ptr, sp -> stack_header.assign_linkage_ptr,
388                sp -> stack_header.clr_ptr, sp -> stack_header.combined_stat_ptr = ainfo.areap;
389           sp -> stack_header.heap_header_ptr = null;
390           sp -> stack_header.sys_link_info_ptr = null;
391           return;
392 %page;
393 grow_lot:
394      entry (a_ring);
395 
396 /* This entry is for initiate to call if it needs to before setting a lot_fault */
397 
398 dcl  a_ring fixed bin (3);
399 
400 dcl  grow_lot_invalid_ring_ condition;
401 
402           ring = a_ring;
403           if ring ^= level$get () then signal grow_lot_invalid_ring_;
404           call make_lot (ring);
405           return;
406 %page;
407 setlp:
408      proc (txp, lp, stp, ring);
409 
410 dcl  lp ptr;
411 dcl  ring fixed bin;
412 dcl  stp ptr;
413 dcl  txp ptr;
414 
415 dcl  segnum fixed bin;
416 dcl  shp ptr;
417 
418           shp = get_sp (ring);
419           segnum = segno (txp);
420           if segnum >= shp -> stack_header.cur_lot_size then do;
421                if segnum > shp -> stack_header.max_lot_size then do;
422                     code = error_table_$invalidsegno;
423                     go to error;
424                     end;
425                call make_lot (ring);                        /* new lot will be max lot size */
426                end;
427 
428           call segno_usage$increment_other_ring (segnum, ring, code);
429                                                             /* setting linkage for segment in target ring is a good
430                                                                reason to hold segment - prevents termination of lower ring gates */
431 
432           shp -> stack_header.lot_ptr -> lot.lp (segnum) = lp;
433           shp -> stack_header.isot_ptr -> isot.isp (segnum) = stp;
434           if baseno (lp) = "0"b then return;                /* just zeroing slot */
435 
436 /* don't disturb flags in lower half of 2nd word in linkage header */
437 
438           if lp -> its.its_mod = "100011"b
439           then return;                                      /*  def ptr already set */
440           else if lp -> its.its_mod = "0"b
441                then lp -> its_unsigned.segno = segno (txp); /* defs in text */
442                else do;                                     /* defs in linkage after links */
443                     lp -> its_unsigned.segno = segno (lp);
444                     lp -> its_unsigned.offset = lp -> its_unsigned.offset + wordno (lp);
445                     end;
446           lp -> its.its_mod = "100011"b;                    /* turn it into a pointer */
447           return;
448 
449      end setlp;
450 %page;
451 getlp:
452      proc (gsp, gtxp, glp, gstp);
453 
454 dcl  (glp, gsp, gstp, gtxp) ptr;
455 dcl  segnum fixed bin;
456 
457           glp, gstp = null;                                 /* assume the worst */
458           segnum = segno (gtxp);
459           if segnum >= gsp -> stack_header.cur_lot_size then return;
460                                                             /* lot isn't that big in this ring */
461           if baseno (gsp -> stack_header.lot_ptr -> lot.lp (segnum))
462                                                             /* non-zero lot entry? */
463           then glp = gsp -> stack_header.lot_ptr -> lot.lp (segnum);
464           else return;                                      /* no linkage for this segno */
465 
466           if baseno (gsp -> stack_header.isot_ptr -> isot.isp (segnum)) ^= "0"b
467           then gstp = gsp -> stack_header.isot_ptr -> isot.isp (segnum);
468 
469           return;
470      end;
471 %page;
472 make_lot:
473      proc (ring);
474 
475 dcl  ring fixed bin;
476 
477 dcl  lotp ptr;
478 dcl  newisotp ptr;
479 dcl  newlotp ptr;
480 dcl  save_max_lot_size fixed bin;
481 dcl  sp ptr;
482 
483 
484 /* This procedure is called to make a larger LOT than the initial lot given a process.
485    It assumes the stack, lot, and clr are already there and makes a new lot
486    by allocating one in the current linkage region.
487 */
488 
489 
490           sp = pds$stacks (ring);
491           lotp = sp -> stack_header.lot_ptr;
492 
493           if sp -> stack_header.cur_lot_size >= sp -> stack_header.max_lot_size
494           then call terminate_proc (error_table_$nrmkst);
495 
496           nwords = 2 * sp -> stack_header.max_lot_size;
497 
498 /* Set stack_header.max_lot_size temporarily so that we won't be called
499    recursively.  Otherwise, this could happen if a segment is
500    created to satisfy the allocate                                                                            */
501 
502           save_max_lot_size = sp -> stack_header.max_lot_size;
503           sp -> stack_header.max_lot_size = sp -> stack_header.cur_lot_size;
504           on cleanup
505                begin;                                       /* in case of crawlout                            */
506                sp -> stack_header.max_lot_size = save_max_lot_size;
507           end;
508 
509           allocate based_array in (sp -> stack_header.clr_ptr -> based_area) set (newlotp);
510 
511           sp -> stack_header.max_lot_size = save_max_lot_size;
512           revert cleanup;
513 
514           newisotp = addrel (newlotp, sp -> stack_header.max_lot_size);
515           nwords = sp -> stack_header.cur_lot_size;
516           newlotp -> based_array = lotp -> based_array;
517           newisotp -> based_array = sp -> stack_header.isot_ptr -> based_array;
518           sp -> stack_header.cur_lot_size = sp -> stack_header.max_lot_size;
519 
520           sp -> stack_header.lot_ptr = newlotp;
521           sp -> stack_header.isot_ptr = newisotp;
522 
523           return;
524      end make_lot;
525 %page;
526 get_sp:
527      proc (ring) returns (ptr);
528 
529 /* This procedure returns a pointer to the initial stack in a ring */
530 
531 dcl  ring fixed bin;
532 
533           if pds$stacks (ring) = null then call makestack (ring);
534 
535           return (pds$stacks (ring));
536 
537      end;
538 %page;
539 %include area_info;
540 %include its;
541 %include linkdcl;
542 %include lot;
543 %include object_info;
544 %include sdw_info;
545 %include stack_header;
546      end;