Multics > Library > Source
17 Nov 1983

link_snap.pl1

History | People | Library | Sites | About

This Multics source file was rescued from the messed-up source archive at MIT.

This piece of the linker is called in response to a linkage fault. It finds the link target and "snaps" the link.

Back to Multics Source index.

                    link_snap.pl1                   11/17/83  0847.5r   11/17/83  0846.4      238383



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* Modified October 1976 by M. Weaver  to handle *system links, to add make_entry entry, and to create targets like *system links */
/* Modified March 1977 by M. Weaver to handle *system links with no init info */
/* Modified May 1977 by M. Weaver to allocate external variable symbol nodes in the user area */
/* Modified September 1977 by M. Weaver to add run unit depth to snapped links */
/* Modified 770815 by PG to use vclock builtin instead of calling vclock subr directly */
/* Modified October 1977 by M. Weaver to not reallocate external variables */
/* Modified January 1981 by J. Bongiovanni for link_meters.incl.pl1 + cleanup */
/* Modified March 1982 by S. Krupp to return error code for connection failure */
/* Modified January 1983 by M. Weaver to call $for_linker entrypoint in set_ext_variable_ */

link_snap$link_fault: proc (mc_ptr);

/* Parameters */

dcl  mc_ptr ptr;                                        /* pointer to machine conditions */
dcl  linkp ptr;                                 /* pointer to link pair to snap */
dcl  rcode fixed bin (35);                              /* error code */
dcl  dummy fixed bin;
dcl  a_caller_ptr ptr;
dcl  a_seg_name char (*);
dcl  a_entrypoint_name char (*);
dcl  a_sptr ptr;
dcl  a_entry entry variable;
dcl  errcode fixed bin (35);

/* Based */

dcl  based_ptr ptr based;
dcl 1 instr (0:1) based aligned,
    2 address bit (18) unal,
    2 op_code bit (12) unal,
    2 mod bit (6) unal;
dcl 1 acc_name aligned based,
    2 nchars fixed bin (8) unaligned,
    2 string char (0 refer (acc_name.nchars)) unaligned;
dcl 1 based_ev aligned based,
    2 ent_ptr ptr,
    2 env_ptr ptr;

/* Automatic */

dcl  make_ptr_call bit (1) aligned init ("0"b);
dcl  make_entry_call bit (1) aligned init ("0"b);
dcl  mapped bit (1) aligned;
dcl  i fixed bin;
dcl  ecode_ptr ptr;
dcl  save_ring fixed bin (3);
dcl  link_pair_ptr ptr;
dcl  inst_ptr ptr;
dcl  code fixed bin (35);
dcl  pf (8) fixed bin (30) init ((8)0);
dcl  time (8) fixed bin (71) init ((8)0);
dcl  header_ptr ptr;
dcl  text_ptr ptr;
dcl  ls_ptr ptr;
dcl  static_ptr ptr;
dcl  symb_ptr ptr;
dcl  def_ptr ptr;
dcl  modifier bit (6) aligned;
dcl  exp_ptr ptr;
dcl  type_ptr ptr;
dcl  type fixed bin;
dcl  sptr ptr;
dcl  init_info_ptr ptr;
dcl  ext_name char (65);
dcl  seg_name char (32);
dcl  nchars fixed bin;
dcl  ext_ptr ptr;
dcl  callerptr ptr;
dcl  entrypoint_name char (32) aligned;
dcl 1 automatic_def aligned,
    2 size fixed bin (8) unal,
    2 string char (32) unaligned;
dcl 1 automatic_seg aligned,
    2 size fixed bin (8) unal,
    2 string char (32) unaligned;
dcl  class fixed bin;
dcl  sgnp ptr;
dcl  other_header_ptr ptr init (null);
dcl  other_static_ptr ptr;
dcl  other_symb_ptr ptr;
dcl  new_ext_ptr ptr;
dcl  value fixed bin;
dcl  dtime fixed bin (35);
dcl  bino fixed bin;
dcl  zero_word bit (36) aligned init ("0"b) int static options (constant);

/* Entries */

dcl  condition_ entry (char(*), entry);
dcl  level$get entry returns (fixed bin (3));
dcl  level$set entry (fixed bin (3));
dcl  page$enter_data entry (ptr unal, fixed bin);
dcl  usage_values entry (fixed bin (30), fixed bin (71));
dcl  rest_of_datmk_ entry (ptr, ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  fs_search entry (ptr, char (*), ptr, fixed bin (35));
dcl  get_defptr_ entry (ptr, ptr, ptr, ptr, fixed bin (35));
dcl  link_man$own_linkage entry (ptr, ptr, ptr, ptr, fixed bin (35));
dcl  link_man$other_linkage entry (ptr, ptr, ptr, ptr, fixed bin (35));
dcl  trap_caller_caller_ entry (ptr, ptr, ptr, ptr, ptr, ptr, fixed bin (35));
dcl  link_snap$link_force entry (ptr, fixed bin, fixed bin (35));
dcl  set_ext_variable_$for_linker entry (char (*), ptr, ptr, bit (1) aligned, ptr, fixed bin (35), ptr, ptr, ptr, ptr);

/* External */

dcl  error_table_$no_call_ptr fixed bin (35) ext;
dcl  error_table_$bad_link_type fixed bin (35) ext;
dcl  error_table_$no_ext_sym fixed bin (35) ext;
dcl  error_table_$no_defs fixed bin (35) ext;
dcl  error_table_$seg_not_found fixed bin (35) ext;
dcl  error_table_$bad_self_ref fixed bin (35) ext;
dcl  error_table_$no_linkage fixed bin (35) ext;
dcl  error_table_$no_sym_seg fixed bin (35) ext;
dcl  error_table_$force_bases fixed bin (35) ext;
dcl  error_table_$defs_loop fixed bin (35) ext;
dcl  error_table_$bad_entry_point_name fixed bin (35) ext;
dcl  error_table_$first_reference_trap fixed bin (35) ext;
dcl  error_table_$illegal_ft2 fixed bin (35) ext;
dcl  error_table_$unexpected_ft2 fixed bin (35) ext;
dcl  error_table_$bad_class_def fixed bin (35) ext;
dcl  error_table_$noalloc fixed bin (35) ext;
dcl  error_table_$notalloc fixed bin (35) ext;
dcl  error_table_$bad_link_target_init_info fixed bin (35) ext;
dcl  pds$link_meters_bins (4) fixed bin (30) ext;
dcl  pds$link_meters_times (4) fixed bin (35) ext;
dcl  pds$link_meters_pgwaits (4) fixed bin (30) ext;
dcl  pds$stacks (0:7) ptr ext;
dcl  sys_info$max_seg_size fixed bin (19) ext;

dcl 1 ahd$link_meters (4) aligned ext like link_meters;

/* Builtins */

dcl (addr, addrel, baseptr, bin, bit, divide, hbound, index, lbound, length, max, min, multiply,
     null, ptr, rel, reverse, substr, unspec, vclock, verify) builtin;

/* Static */

dcl  its_value bit (6) aligned static init ("100011"b) options (constant);
dcl  ft2 bit (6) aligned static init ("100110"b) options (constant);
dcl  indirect bit (6) aligned static init ("010000"b) options (constant);

/*  */

/* Code for link_fault starts here....... */

        mcp = mc_ptr;                           /* get copy of input pointer */
        ecode_ptr = null;
        save_ring = level$get ();                       /* get current validation level */
        scup = addr (mcp -> mc.scu (0));                /* get pointer to SCU data */
        call level$set (bin (scu.ppr.prr, 3));          /* set validation level appropriately */
        link_pair_ptr = ptr (baseptr (bin (scu.tpr.tsr, 15)), scu.ca); /* get pointer to faulting link pair */

        call page$enter_data (ptr (baseptr (bin (scu.ppr.psr, 15)), scu.ilc), linkage_fault_start); /* trace the fault */

/* Make a check to see if FT2 is in instruction */

        inst_ptr = ptr (baseptr (bin (scu.ppr.psr, 15)), scu.ilc); /* get pointer to faulting instruction */
        if inst_ptr -> its.its_mod = ft2 then do;
             code = error_table_$unexpected_ft2;
             goto ERROR;
        end;

join:   call usage_values (pf (1), time (1));           /* meter linkage fault time */
        if link_pair_ptr -> link.ft2 ^= ft2 then do;
             if mcp = null then code = 0;
             else code = error_table_$illegal_ft2;
             goto ERROR;
        end;

        header_ptr = addrel (link_pair_ptr, link_pair_ptr -> link.head_ptr); /* get pointer to linkage section */
        text_ptr = baseptr (header_ptr -> header.stats.segment_number); /* get pointer to base of text */


        if addr (header_ptr -> header.def_ptr) -> its.its_mod ^= its_value then do; /* check validity of def pointer */
             code = error_table_$no_defs;
             goto ERROR;
        end;

        if header_ptr -> virgin_linkage_header.first_ref_relp ^= "0"b then do; /* check for first reference trap */
             code = error_table_$first_reference_trap;
             goto ERROR;
        end;

/*  */

/* Come here after validity checks have all passed. Start decoding the linkage information. */

        code = 0;
        def_ptr = header_ptr -> header.def_ptr;         /* get def pointer */
        modifier = link_pair_ptr -> its.mod;            /* save modifier from link pair */
        exp_ptr = addrel (def_ptr, link_pair_ptr -> link.exp_ptr); /* get pointer to expression word */
        type_ptr = addrel (def_ptr, exp_ptr -> exp_word.type_ptr); /* get pointer to type pair */

        type = bin (type_ptr -> type_pair.type, 18);    /* extract link type from type pair */

        if type ^= 6 then do;                   /* trap_ptr means something different for type 6 links */
             if mcp ^= null then do;                    /* only look for trap-before-link at link_fault entry */
                if type = 5 then do;            /* must check further */
                     if bin (type_ptr -> type_pair.seg_ptr, 18) = 5 then do; /* *system */
                        ext_name = addrel (def_ptr, type_ptr -> type_pair.ext_ptr) -> acc_name.string;
process_star_system1:   init_info_ptr = addrel (def_ptr, type_ptr -> type_pair.trap_ptr);
                        if mcp ^= null then sb = ptr (mcp -> prs (6), 0); /* fault entry */
                        else sb = pds$stacks (level$get ()); /* force entry */
                        if init_info_ptr = def_ptr then init_info_ptr = null; /* no init info */
process_star_system2:   call set_ext_variable_$for_linker (ext_name, init_info_ptr, sb, ("0"b), 
                             sptr, code, mcp, def_ptr, type_ptr, link_pair_ptr);
                        if code ^= 0 then goto ERROR;
                        sptr = sptr -> variable_node.vbl_ptr; /* link gets snapped to variable itself */
                        call snap;
                        call finish_and_meter;
                        return;
                     end;
                end;
                else if type_ptr -> type_pair.trap_ptr ^= "0"b then do; /* check trap-before-link if not type 6 */
                     call map_datmk_link;
                     if mapped then goto process_star_system2; /* converted to *system  */
                     call adjust_mc;            /* diddle the machine conditions */
                     call trap_caller_caller_ (mcp, header_ptr, def_ptr, type_ptr, link_pair_ptr, (null), code);
                     goto ERROR;                        /* usually don't return, but if we do.... */
                end;
             end;
        end;

/* Dispatch on type */

        if type = 1 then do;                    /*     *|exp,m     */
             call self_reference;
             call snap;
             call finish_and_meter;
             return;
        end;

        else if type = 2 then do;                       /*     PR|[ext]+exp,m     */
             code = error_table_$bad_link_type;
             goto ERROR;
        end;


        else if type = 3 then do;                       /*     <seg>|exp,m     */
             call search_for_segment;
             if sptr = null then goto ERROR;
             call snap;
             call finish_and_meter;
             return;
        end;


        else if type = 4 then do;                       /*     <seg>|[ext]+exp,m     */
             call search_for_segment;
             if sptr = null then goto ERROR;
             call condition_("seg_fault_error", connect_fail_handler_);
             call get_ext_ptr;
             call get_definition ("0"b);
             call snap;
             call finish_and_meter;
             return;
        end;


        else if type = 5 then do;                       /*     *|[ext]+exp,m     */
             call self_reference;
             sgnp = addr (zero_word);                   /* set to name that get_defptr_ won't find */
             call get_ext_ptr;
             call get_definition ("0"b);
             call snap;
             call finish_and_meter;
             return;
        end;

        else if type = 6 then do;                       /*     <seg>|[ext]+exp,m (create if not found)     */
                                                /*     see if this appears to be a link to pl1 ext static or
                                                   fortran common; if so, treat as *system link     */
             sgnp = addrel (def_ptr, type_ptr -> type_pair.seg_ptr);
             ext_ptr = addrel (def_ptr, type_ptr -> type_pair.ext_ptr);
             if sgnp -> acc_name.string = "stat_" then ext_name = ext_ptr -> acc_name.string;
                                                /* PL/I external static */
             else if ext_ptr -> acc_name.nchars = 0 then do;
                i = index (sgnp -> acc_name.string, ".com");
                if (i = 0) | (i < (sgnp -> acc_name.nchars - 3)) then goto process_type_6;
                ext_name = substr (sgnp -> acc_name.string, 1, i - 1); /* fortran common */
                if ext_name = "b_" then ext_name = "blnk*com"; /* unlabelled common  */
             end;
             else if sgnp -> acc_name.string = "cobol_fsb_" then ext_name = "cobol_fsb_" || ext_ptr -> acc_name.string;
             else goto process_type_6;
             goto process_star_system1;
process_type_6:
             call search_for_segment;
             if sptr = null then do;                    /* segment not found, try to create as *system */
                code = 0;                               /* so it won't come back to haunt us ... */
                ext_name = sgnp -> acc_name.string || "$" || ext_ptr -> acc_name.string;
                go to process_star_system1;
             end;
             else do;
                  call condition_("seg_fault_error", connect_fail_handler_);
                call get_ext_ptr;
                if ext_ptr ^= null then call get_definition ("0"b);
             end;
             call snap;
             call finish_and_meter;
             return;
        end;

        else do;
             code = error_table_$bad_link_type;
             goto ERROR;
        end;
                                                /*  */

ERROR:
        if make_ptr_call | make_entry_call then do;
             errcode = code;
             return;
        end;
        if mcp ^= null then do;                 /* normal fault entry */
             mc.errcode = code;
             call adjust_mc;
             call level$set (save_ring);
        end;
        else rcode = code;
        call page$enter_data (baseptr (0), linkage_fault_end);
        return;

link_force: entry (linkp, dummy, rcode);                /* entry to snap a link not faulted on */

        mcp = null;                             /* indicates link_force entry */
        link_pair_ptr = linkp;
        ecode_ptr = addr (rcode);
        goto join;


make_ptr:       entry (a_caller_ptr, a_seg_name, a_entrypoint_name, a_sptr, errcode);

        a_sptr = null;
        make_ptr_call = "1"b;
make_join:
        mcp = null;
        call usage_values (pf (1), time (1));
        call page$enter_data (baseptr (0), linkage_fault_start);

        ecode_ptr = addr (errcode);
        errcode = 0;
        callerptr = a_caller_ptr;
        seg_name = a_seg_name;
        entrypoint_name = a_entrypoint_name;

        call fs_search (callerptr, seg_name, sptr, code); /* search for given segment */
        if code ^= 0 then goto ERROR;
        call condition_("seg_fault_error", connect_fail_handler_);

        nchars = 33 - verify (reverse (entrypoint_name), " ");
        if nchars = 33 then do;                 /* null entrypoint name */
             if make_ptr_call then a_sptr = sptr;
             else do;
                call combine_other_linkage;             /* linkage must be combined before procedure is called */
                addr (a_entry) -> based_ev.ent_ptr = sptr;
             end;
             return;
        end;
        ext_ptr = addr (automatic_def);         /* fabricate an external entrypoint (segdef) name */
        substr (unspec (automatic_def), 1, 36) = (36)"0"b; /* must pad first word with 0 for get_defptr_ */
        automatic_def.size = nchars;
        substr (automatic_def.string, 1, nchars) = substr (entrypoint_name, 1, nchars);

        sgnp = addr (automatic_seg);                    /* fabricate reference name definition */
        nchars = 33 - verify (reverse (seg_name), " ");
        substr (unspec (automatic_seg), 1, 36) = (36)"0"b; /* must pad first word with 0 for get_defptr_ */
        automatic_seg.size = nchars;
        substr (automatic_seg.string, 1, nchars) = substr (seg_name, 1, nchars);

        type = 4;
        if seg_name = entrypoint_name then call get_definition ("1"b);
        else call get_definition ("0"b);
        if code ^= 0 then do;                   /* look for segname$main_ */
             automatic_def.size = 5;
             automatic_def.string = "main_";
             call get_definition ("0"b);
        end;
        call finish_and_meter;
        if make_ptr_call then a_sptr = sptr;
        else addr (a_entry) -> based_ev.ent_ptr = sptr;

        return;



make_entry: entry (a_caller_ptr, a_seg_name, a_entrypoint_name, a_entry, errcode);

        make_entry_call = "1"b;
        addr (a_entry) -> based_ev.env_ptr = null;
        goto make_join;
                                                /*  */

self_reference: proc;


/* This internal procedure resolves type 1 and 5 links which are self relative links.
   This procedure assumes the following variables have been set before calling:

   type_ptr
   text_ptr
   header_ptr
   symp_ptr
   static_ptr

   It sets the variable "sptr" to point to the base of the appropriate region.
*/

             call link_man$own_linkage (text_ptr, ls_ptr, static_ptr, symb_ptr, code);
             if code ^= 0 then goto ERROR;

             class = bin (type_ptr -> type_pair.seg_ptr, 18); /* extract class from type pair */

             if class = 0 then sptr = text_ptr;
             else if class = 1 then sptr = header_ptr;
             else if class = 2 then sptr = symb_ptr;
             else if class = 4 then sptr = static_ptr;
             else do;
                code = error_table_$bad_self_ref;
                goto ERROR;
             end;

             return;

        end self_reference;

/*  */

get_ext_ptr: proc;


/* This procedure is used to calculate the value for the variable "ext_ptr". It assumes the following
   variables have been set before calling:

   type_ptr
   def_ptr
   type

   It sets the variable "ext_ptr" to point to the ACC string specifying the external name being searched for.
   If no external name is specified in the type pair, "ext_ptr" is returned as null.
   It sets ext_ptr to null if we are resolving a type 6 link for which no external name was given.
*/

             ext_ptr = null;
             if type_ptr -> type_pair.ext_ptr = "0"b then return;
             ext_ptr = addrel (def_ptr, type_ptr -> type_pair.ext_ptr);
             if type = 6 then if ext_ptr -> acc_name.nchars = 0 then ext_ptr = null;
             return;

        end get_ext_ptr;

/*  */

search_for_segment: proc;


/* This procedure uses the search rules to search for a segment specified in the "seg_ptr"
   field of a type pair. It copies the name into the variable "seg_name"; it saves the length of the name
   in the variable "nchars"; it saves a pointer to the ACC string in "sgnp".
   It assumes the following variables have been set before calling:

   def_ptr
   type_ptr
   text_ptr

   Upon return, the variable "sptr" is left pointing to the appropriate segment.
   If "sptr" is returned as null, the segment could not be found and "code" is returned nonzero.
*/

             call usage_values (pf (2), time (2));
             sgnp = addrel (def_ptr, type_ptr -> type_pair.seg_ptr);
             nchars = bin (sgnp -> name.nchars, 9);
             seg_name = substr (sgnp -> name.char_string, 1, nchars);

             call fs_search (text_ptr, seg_name, sptr, code);
             call usage_values (pf (3), time (3));
             return;

        end search_for_segment;

/*  */

get_definition: proc (will_retry);



/* this procedure searches the definitions of the appropriate segment in order to find the
   segdef'd location specified by the link pair.  It assumes the following variables have been set before calling:

   sgnp
   ext_ptr
   sptr

   It returns after setting "sptr" to point to the appropriate target of the link.
*/

dcl  will_retry bit (1) aligned;

             if ext_ptr = null then do;
                code = 0;
                return;
             end;

             call combine_other_linkage;

             call usage_values (pf (6), time (6));
             call get_defptr_ (other_header_ptr -> header.def_ptr, sgnp, ext_ptr, new_ext_ptr, code);
             call usage_values (pf (7), time (7));
             if code ^= 0 then do;                      /* couldn't find segdef */
                if will_retry then if code = error_table_$no_ext_sym then return;
                                                /* will then look for main_ */
                goto ERROR;
             end;

             value = bin (new_ext_ptr -> definition.value, 18);
             class = bin (new_ext_ptr -> definition.class, 18);

             if class = 0 then sptr = ptr (sptr, value);        /* text relative */
             else if class = 1 then sptr = addrel (other_header_ptr, value); /* link relative */
             else if class = 2 then sptr = addrel (other_symb_ptr, value);
             else if class = 4 then sptr = addrel (other_static_ptr, value);
             else do;
                code = error_table_$bad_class_def;
                goto ERROR;
             end;

             return;

        end get_definition;

/*  */
combine_other_linkage: proc;



/* this procedure calls link_man to get a pointer to the target segment's active linkage
   section, combining it if necessary.  It assumes the following variables have been set before calling:

   sptr

   It returns after obtaining other_header_ptr, other_static_ptr, and other_symb_ptr.
*/

             call usage_values (pf (4), time (4));
             call link_man$other_linkage (sptr, other_header_ptr, other_static_ptr, other_symb_ptr, code);
             call usage_values (pf (5), time (5));
             if code ^= 0 then goto ERROR;              /* couldn't find linkage for segment pointed to by sptr */

             if other_header_ptr = null then do;
                code = error_table_$no_linkage;
                goto ERROR;
             end;

             return;

        end combine_other_linkage;

/*  */

snap:   proc;



/* This procedure fills in the link pair with the appropriate pointer value.
   It also modifies the machine conditions so that the linkage fault may be restarted. It
   will only do this if mcp is nonnull, i.e. we were cllled via the link_fault entry. It assumes the
   following variables have been set before calling:

   mcp
   link_pair_ptr
   sptr
   exp_ptr
   modifier
   scup
   code
   save_ring

*/

             if exp_ptr ^= null then sptr = addrel (sptr, exp_ptr -> exp_word.exp); /* update sptr */
             link_pair_ptr -> based_ptr = sptr;
             link_pair_ptr -> its.mod = modifier;
             sb = pds$stacks (level$get ());            /* get ptr to stack header */
             link_pair_ptr -> link.run_depth = sb -> stack_header.run_unit_depth;

             if mcp ^= null then do;
                call level$set (save_ring);             /* restore validation level */
                call adjust_mc;
                mcp -> mc.errcode = code;
             end;

        end snap;
                                                /*  */

adjust_mc: proc;

/* This procedure modifies the hardware machine conditions so that they may be restarted without
   retaking the linkage fault. The procedure assumes that scup is pointing at the SCU data */

             addr (scu.even_inst) -> instr (0).address = scu.ca;
             addr (scu.even_inst) -> instr (0).mod = indirect;

             return;

        end adjust_mc;

/*  */
map_datmk_link: proc;

/* This procedure checks to see if a link is a type 4 link to stat_
   with a trap before link to datmk_.  If it is, the variables
   ext_name and init_info_ptr are set so the link can be treated as a
   *system link and the variable mapped is set to "1"b.
   This procedure assumes the following variables have been set
   before calling:

   def_ptr
   type_ptr

   It sets the variables mapped, ext_name, init_info_ptr before returning.
*/



             mapped = "0"b;
             if type = 4
             then if addrel (def_ptr, type_ptr -> type_pair.seg_ptr) -> acc_name.string = "stat_"
                then if addrel (def_ptr, addrel (def_ptr, addrel (def_ptr, addrel (header_ptr, addrel (def_ptr,
                     type_ptr -> type_pair.trap_ptr)
                     -> trap_word.call_ptr)
                     -> link.exp_ptr)
                     -> exp_word.type_ptr)
                     -> type_pair.seg_ptr)
                     -> acc_name.string = "datmk_" then do;
                        inst_ptr = addrel (header_ptr, addrel (def_ptr,
                             type_ptr -> type_pair.trap_ptr) -> trap_word.arg_ptr);
                        call link_snap$link_force (inst_ptr, 0, code); /* snap link to init info */
                        if code ^= 0 then goto ERROR;
                        init_info_ptr = inst_ptr -> based_ptr;
                        ext_name = addrel (def_ptr, type_ptr -> type_pair.ext_ptr) -> acc_name.string;
                        mapped = "1"b;
                     end;

             return;
        end;

/*  */
finish_and_meter: proc;

/* This procedure performs the last steps after handling the linkage fault.
*/

             if code = 0 then do;                       /* only meter if no error */
                call usage_values (pf (8), time (8));
                dtime = bin (time (8)-time (1), 35);    /* get VCPU time to handle fault */
                bino = max (1, min (4, divide (dtime, 25000, 17, 0)+1)); /* get bin number (25msec wide) */
                pds$link_meters_bins (bino) = pds$link_meters_bins (bino) + 1;
                pds$link_meters_pgwaits (bino) = pds$link_meters_pgwaits (bino)+pf (8)-pf (1);
                pds$link_meters_times (bino) = pds$link_meters_times (bino)+dtime;

                ahd$link_meters (bino).total = ahd$link_meters (bino).total + 1;
                ahd$link_meters (bino).pf = ahd$link_meters (bino).pf+pf (8)-pf (1);
                ahd$link_meters (bino).time = ahd$link_meters (bino).time+dtime;
                if ^(make_ptr_call | make_entry_call) & (type = 3 | type = 4) then do;
                     ahd$link_meters (bino).search_pf = ahd$link_meters (bino).search_pf+pf (3)-pf (2);
                     ahd$link_meters (bino).search_time = ahd$link_meters (bino).search_time+time (3)-time (2);
                     ahd$link_meters (bino).get_linkage_pf = ahd$link_meters (bino).get_linkage_pf+pf (5)-pf (4);
                     ahd$link_meters (bino).get_linkage_time = ahd$link_meters (bino).get_linkage_time+time (5)-time (4);
                     ahd$link_meters (bino).defsearch_pf = ahd$link_meters (bino).defsearch_pf+pf (7)-pf (6);
                     ahd$link_meters (bino).defsearch_time = ahd$link_meters (bino).defsearch_time+time (7)-time (6);
                end;
                else if type = 6 then do;
                     ahd$link_meters (bino).total_type_6 = ahd$link_meters (bino).total_type_6 + 1;
                     ahd$link_meters (bino).type_6_pf = ahd$link_meters (bino).type_6_pf+pf (8)-pf (1);
                     ahd$link_meters (bino).type_6_time = ahd$link_meters (bino).type_6_time+dtime;
                end;
                else do;                                /* types 1, 2, and 5 */
                     if (make_ptr_call | make_entry_call)
                     then ahd$link_meters (bino).tot_make_ptr = ahd$link_meters (bino).tot_make_ptr + 1;
                     ahd$link_meters (bino).total_others = ahd$link_meters (bino).total_others + 1;
                     ahd$link_meters (bino).others_pf = ahd$link_meters (bino).others_pf+pf (8)-pf (1);
                     ahd$link_meters (bino).others_time = ahd$link_meters (bino).others_time+dtime;
                end;

/* Check for first-ref-trap */

                if other_header_ptr ^= null then do;
                     if other_header_ptr -> virgin_linkage_header.first_ref_relp ^= "0"b then do; /* trap ON */
                        if mcp ^= null then call adjust_mc; /* diddle MC if necessary */
                        if make_ptr_call then a_sptr = sptr;
                        else if make_entry_call then addr (a_entry) -> based_ev.ent_ptr = sptr;
                        call trap_caller_caller_ (mcp, other_header_ptr, null, null, null, ecode_ptr, code);
                        if mcp ^= null then mcp -> mc.errcode = code; /* in case trap_caller_caller_ returned */
                     end;
                end;
             end;
             call page$enter_data ((sptr), linkage_fault_end);
             if (make_ptr_call | make_entry_call) then errcode = code;
             else if mcp = null then rcode = code;
             else mc.errcode = code;
             return;

        end finish_and_meter;

/*  */

connect_fail_handler_: proc(a_mc_ptr, a_condition_name, a_wc_ptr, a_info_ptr, a_continue_flag);

  /* This procedure expects sptr to be set and is only called
     on a seg_fault_error.  It continues signalling seg_fault_error if
     the fault occured on some unexpected segment (a segment other
     than that specified by sptr) otherwise it returns an error code. */

  /* Parameter */

     dcl a_condition_name char(*);
     dcl a_continue_flag bit(1) aligned;
     dcl a_info_ptr ptr;
     dcl a_mc_ptr ptr;
     dcl a_wc_ptr ptr;

  /* Automatic */

     dcl faulted_segno fixed bin(18);
     dcl segno fixed bin(18);
     dcl scu_ptr ptr;

  /* Builtin */

     dcl (addr, baseno, bin) builtin;

               a_continue_flag = "0"b;
             scu_ptr = addr(a_mc_ptr->mc.scu);
             faulted_segno = bin(scu_ptr->scu.tpr.tsr, 18);
             segno = bin(baseno(sptr), 18);

             if faulted_segno ^= segno
             then do;
                  a_continue_flag = "1"b;
                return;
             end;

             code = a_mc_ptr->mc.errcode;
             go to ERROR;

end connect_fail_handler_;

/*  */

dcl 1 datmk_info aligned,
%include datmk_info;
%include trace_types;
%include mc;
%include its;
%include linkdcl;

%include definition;

%include system_link_names;

%include stack_header;

%include link_meters;

     ;                                          /* for ind */

     end link_snap$link_fault;

"This material is presented to ensure dissemination of scholarly and technical work. Copyright and all rights therein are retained by authors or by other copyright holders. All persons copying this information are expected to adhere to the terms and constraints invoked by each author's copyright. In most cases, these works may not be reposted without the explicit permission of the copyright holder."