1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) Honeywell Information Systems Inc., 1985 *
   4         *                                                         *
   5         *********************************************************** */
   6 
   7 /* format: off */
   8 
   9 /* Multics Control Point Manager -- The control point manager provides a simple form of mulitasking within a process.
  10    Each control point is given a separate stack and, optionally, a separate of set the standard I/O switches.  Once given
  11    control, a control point will continue to run until it either kills itself or attempts to block on an IPC event
  12    channel.  This module implements the primitive operations of the control point manager. */
  13 
  14 /****^  HISTORY COMMENTS:
  15   1) change(86-08-12,Kissel), approve(86-08-12,MCR7473),
  16      audit(86-10-20,Fawcett), install(86-11-03,MR12.0-1206):
  17      Written to support control point management in March 1985 by G. Palter
  18      based on C. Hornig's task_ctl_.
  19                                                    END HISTORY COMMENTS */
  20 
  21 /* format: style3,linecom */
  22 
  23 cpm_:
  24      procedure ();
  25 
  26 ERROR_RETURN_FROM_CPM_:
  27           return;                                           /* not an entrypoint */
  28 
  29 
  30 /* Parameters */
  31 
  32 dcl       P_control_point_id  bit (36) aligned parameter;
  33 dcl       P_code              fixed binary (35) parameter;
  34 
  35 dcl       P_ccpi_ptr          pointer parameter;            /* create: -> description of the new control point */
  36 
  37 dcl       P_user_cl_intermediary                            /* *user_cl_intermediary: the user's CL intermediary */
  38                               entry (bit (1) aligned) variable parameter;
  39 
  40 dcl       P_userproc                                        /* generate_call*: the entrypoint to be called */
  41                               entry (pointer) variable parameter;
  42 dcl       P_userproc_info_ptr pointer parameter;            /* generate_call*: the argument to the user's entrypoint */
  43 
  44 dcl       P_pushed_preferred_control_point                  /* (push pop)_preferred_control_point: set ON => we ... */
  45                               bit (1) aligned parameter;    /* ... pushed the preferred control point */
  46 
  47 dcl       P_cpma_ptr          pointer parameter;            /* get_*_meters: -> the meters */
  48 
  49 dcl       P_cpd_ptr           pointer parameter;            /* update_state_caller: -> the control point */
  50 dcl       P_new_state         fixed binary parameter;       /* update_state_caller: new state for the control point */
  51 
  52 dcl       P_mask              bit (36) aligned parameter;   /* *mask_ips_interrupts_caller: the current IPS mask */
  53 
  54 
  55 /* Remaining declarations */
  56 
  57 dcl       1 current_control_point_data                      /* the current control point's definition */
  58                               like control_point_data aligned based (current_cpd_ptr);
  59 dcl       current_cpd_ptr     pointer;
  60 
  61 dcl       1 parent_control_point_data                       /* the identified control point's parent's definition */
  62                               like control_point_data aligned based (control_point_data.parent);
  63 
  64 dcl       1 io_switches       like control_point_data.io_switches aligned based (ios_ptr);
  65 dcl       ios_ptr             pointer;
  66 
  67 dcl       system_area         area based (system_area_ptr);
  68 dcl       system_area_ptr     pointer;
  69 
  70 dcl       1 decoded_control_point_id
  71                               aligned,
  72             2 stack_segno     bit (18) unaligned,
  73             2 unique_bits     bit (18) unaligned;
  74 
  75 dcl       1 userproc_arg_list aligned,
  76             2 header          like arg_list.header,
  77             2 arg_ptrs        (1) pointer;
  78 
  79 dcl       generate_call_flags bit (36) aligned;
  80 dcl       prior_state         fixed binary;
  81 dcl       target_cpd_ptr      pointer;
  82 
  83 dcl       stack_idx           fixed binary;
  84 
  85 dcl       mask                bit (36) aligned;
  86 
  87 dcl       (
  88           cpm_et_$already_started,
  89           cpm_et_$already_stopped,
  90           cpm_et_$cant_destroy_root,
  91           cpm_et_$cant_stop_root,
  92           cpm_et_$cant_wakeup_when_stopped,
  93           cpm_et_$control_point_not_found,
  94           cpm_et_$preferred_cant_be_stopped,
  95           cpm_et_$preferred_stack_overflow,
  96           cpm_et_$wakeup_ignored,
  97           error_table_$badcall,
  98           error_table_$out_of_sequence,
  99           error_table_$unimplemented_version
 100           )                   fixed binary (35) external;
 101 
 102 dcl       (
 103           sys_info$all_valid_ips_mask,
 104           sys_info$comm_privilege,
 105           sys_info$dir_privilege,
 106           sys_info$ipc_privilege,
 107           sys_info$rcp_privilege,
 108           sys_info$ring1_privilege,
 109           sys_info$seg_privilege,
 110           sys_info$soos_privilege
 111           )                   bit (36) aligned external;
 112 
 113 dcl       continue_to_signal_ entry (fixed binary (35));
 114 dcl       (
 115           cpm_alm_$call_overseer,
 116           cpm_alm_$call_generate_call
 117           )                   entry ();
 118 dcl       cpm_alm_$switch_stacks
 119                               entry (pointer);
 120 dcl       cpm_initialize_     entry ();
 121 dcl       cpm_overseer_$cl_intermediary
 122                               entry (bit (36) aligned);
 123 dcl       cpm_overseer_$generate_call
 124                               entry (pointer, entry (pointer), pointer);
 125 dcl       (
 126           cu_$get_cl_intermediary,
 127           cu_$set_cl_intermediary
 128           )                   entry (entry (bit (36) aligned));
 129 dcl       get_privileges_     entry () returns (bit (36) aligned);
 130 dcl       get_system_free_area_
 131                               entry () returns (pointer);
 132 dcl       get_temp_segment_   entry (character (*), pointer, fixed binary (35));
 133 dcl       hcs_$get_process_usage
 134                               entry (pointer, fixed binary (35));
 135 dcl       hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned);
 136 dcl       hcs_$set_ips_mask   entry (bit (36) aligned, bit (36) aligned);
 137 dcl       hcs_$set_stack_ptr  entry (pointer);
 138 dcl       ioa_$rsnnl          entry () options (variable);
 139 dcl       ipc_$reassign_call_channels
 140                               entry (bit (36) aligned, bit (36) aligned);
 141 dcl       ipc_$wait_for_an_event
 142                               entry ();
 143 dcl       release_temp_segment_
 144                               entry (character (*), pointer, fixed binary (35));
 145 dcl       sub_err_            entry () options (variable);
 146 dcl       (
 147           system_privilege_$comm_priv_on,
 148           system_privilege_$comm_priv_off,
 149           system_privilege_$dir_priv_on,
 150           system_privilege_$dir_priv_off,
 151           system_privilege_$ipc_priv_on,
 152           system_privilege_$ipc_priv_off,
 153           system_privilege_$rcp_priv_on,
 154           system_privilege_$rcp_priv_off,
 155           system_privilege_$ring1_priv_on,
 156           system_privilege_$ring1_priv_off,
 157           system_privilege_$seg_priv_on,
 158           system_privilege_$seg_priv_off,
 159           system_privilege_$soos_priv_on,
 160           system_privilege_$soos_priv_off
 161           )                   entry (fixed binary (35));
 162 
 163 dcl       (addr, addwordno, baseno, baseptr, binary, bit, bool, clock, codeptr, currentsize, hbound, length, mod, null,
 164           stackbaseptr, string, substr, unspec)
 165                               builtin;
 166 
 167 dcl       (any_other, cleanup)
 168                               condition;
 169 %page;
 170 /* Create a new control point which is left in the STOPPED state */
 171 
 172 create:
 173      entry (P_ccpi_ptr, P_control_point_id, P_code);
 174 
 175           if stackbaseptr () -> stack_header.cpm_enabled = ""b
 176           then do;                                          /* first time in the process */
 177                     call cpm_initialize_ ();
 178                     current_cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr;
 179                end;
 180 
 181           ccpi_ptr = P_ccpi_ptr;                            /* copy input parameter for the internal procedure */
 182 
 183           system_area_ptr = get_system_free_area_ ();
 184 
 185           mask = ""b;                                       /* for any_other handler */
 186           on any_other call any_other_handler ();
 187 
 188           cpd_ptr = null ();                                /* for cleanup handler */
 189           on cleanup
 190                begin;
 191                     if cpd_ptr ^= null ()
 192                     then call destroy_control_point (cpd_ptr);
 193                end;
 194 
 195           call create_control_point ();                     /* does most of the work */
 196 
 197           call push_call_frame (cpm_alm_$call_overseer, unspec (create_control_point_info),
 198                create_control_point_info.initproc.entry, create_control_point_info.initproc.info_ptr);
 199 
 200           P_control_point_id = control_point_data.id;
 201           P_code = 0;                                       /* success */
 202 
 203           return;
 204 
 205 
 206 /* Control arrives here iff an error occured while creating the control point */
 207 
 208 ERROR_RETURN_FROM_CPM_$CREATE:
 209           if cpd_ptr ^= null ()
 210           then call destroy_control_point (cpd_ptr);
 211           return;                                           /* create_failure procedure has already set P_code */
 212 %page;
 213 /* Destroy the specified control point -- This entrypoint queues a call to cpm_$call_self_destruct onto the target control
 214    point's stack and then forces the scheduler to run that control point. */
 215 
 216 destroy:
 217      entry (P_control_point_id, P_code);
 218 
 219           call check_initialization ("cpm_$destroy");       /* aborts if not initialized */
 220 
 221           call find_control_point (P_control_point_id);     /* sets cpd_ptr or aborts the call entirely */
 222           if cpd_ptr = addr (cpm_data_$root_control_point_data)
 223           then do;                                          /* the root control point is sacred */
 224                     P_code = cpm_et_$cant_destroy_root;
 225                     return;
 226                end;
 227 
 228           call generate_call (P_control_point_id, call_self_destruct, null (), P_code);
 229 
 230           return;
 231 
 232 
 233 
 234 /* This entrypoint is called by cpm_$destroy on the stack of the control point which is to be destroyed.  It does a
 235    non-local goto to the control point's destroy label which has been initialized to cpm_$self_destruct.  The non-local
 236    goto will unwind the entire stack allowing any cleanup handlers to be run. */
 237 
 238 call_self_destruct:
 239      entry ();
 240 
 241           cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr;
 242 
 243           if codeptr (control_point_data.destroy) = codeptr (self_destruct)
 244           then go to control_point_data.destroy;            /* transfer to the self_destruct entrypoint */
 245           else call sub_err_ (cpm_et_$cant_destroy_root, cpm_data_$subsystem_name, ACTION_CANT_RESTART, null (), 0);
 246 
 247 
 248 
 249 /* This entrypoint is not actually called but, rather, is the target of the non-local goto performed above by
 250    cpm_$call_self_destruct.  This entrypoint will update the control point's state to DEAD and then invoke the scheduler
 251    to find something else to do. */
 252 
 253 self_destruct:
 254      entry ();
 255 
 256           current_cpd_ptr, cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr;
 257 
 258           mask = ""b;                                       /* for any_other handler */
 259           on any_other call any_other_handler ();
 260 
 261           call update_state (CPM_DESTROYED);                /* this control point is ready for destruction */
 262 
 263           do while ("1"b);                                  /* find something else to do */
 264                call scheduler$find_runnable ();
 265           end;
 266 %page;
 267 /* Start the specified control point -- Places the control point into the READY state if it was STOPPED */
 268 
 269 start:
 270      entry (P_control_point_id, P_code);
 271 
 272           call check_initialization ("cpm_$start");
 273 
 274           call find_control_point (P_control_point_id);     /* sets cpd_ptr or aborts the call entirely */
 275 
 276           mask = ""b;                                       /* for any_other handler */
 277           on any_other call any_other_handler ();
 278 
 279           if control_point_data.state = CPM_STOPPED
 280           then do;
 281                     call update_state (CPM_READY);
 282                     P_code = 0;                             /* success */
 283                end;
 284 
 285           else P_code = cpm_et_$already_started;            /* it's already running or blocked */
 286 
 287           return;
 288 
 289 
 290 
 291 /* Stop the specified control point -- Places the control point into the STOPPED state if it was READY or BLOCKED */
 292 
 293 stop:
 294      entry (P_control_point_id, P_code);
 295 
 296           call check_initialization ("cpm_$stop");
 297 
 298           call find_control_point (P_control_point_id);     /* sets cpd_ptr or aborts the call entirely */
 299           if cpd_ptr = addr (cpm_data_$root_control_point_data)
 300           then do;                                          /* the root control point is sacred */
 301                     P_code = cpm_et_$cant_stop_root;
 302                     return;
 303                end;
 304 
 305           mask = ""b;                                       /* for any_other handler */
 306           on any_other call any_other_handler ();
 307 
 308           if (control_point_data.state = CPM_READY) | (control_point_data.state = CPM_BLOCKED)
 309           then do;
 310                     call update_state (CPM_STOPPED);
 311                     P_code = 0;                             /* success */
 312                end;
 313 
 314           else P_code = cpm_et_$already_stopped;            /* it was stopped earlier */
 315 
 316           return;
 317 %page;
 318 /* Block the current control point */
 319 
 320 block:
 321      entry ();
 322 
 323           call check_initialization ("cpm_$block");         /* sets current_cpd_ptr */
 324           cpd_ptr = current_cpd_ptr;
 325 
 326           mask = ""b;                                       /* for any_other handler */
 327           on any_other call any_other_handler ();
 328 
 329           if control_point_data.state = CPM_READY
 330           then call update_state (CPM_BLOCKED);
 331 
 332           return;
 333 
 334 
 335 
 336 /* Wakeup the specified control point -- Places the control point into the READY state if it was BLOCKED */
 337 
 338 wakeup:
 339      entry (P_control_point_id, P_code);
 340 
 341           call check_initialization ("cpm_$wakeup");
 342 
 343           call find_control_point (P_control_point_id);     /* sets cpd_ptr or aborts the call entirely */
 344 
 345           mask = ""b;                                       /* for any_other handler */
 346           on any_other call any_other_handler ();
 347 
 348           if control_point_data.state = CPM_BLOCKED
 349           then do;
 350                     call update_state (CPM_READY);
 351                     P_code = 0;                             /* success */
 352                end;
 353 
 354           else if control_point_data.state = CPM_READY      /* it's already awake */
 355           then P_code = cpm_et_$wakeup_ignored;
 356 
 357           else P_code = cpm_et_$cant_wakeup_when_stopped;   /* it's stopped and must be started first */
 358 
 359           return;
 360 %page;
 361 /* Run the scheduler to find the highest priority ready control point and give control to said control point */
 362 
 363 scheduler:
 364      entry ();
 365 
 366           call check_initialization ("cpm_$scheduler");
 367 
 368           mask = ""b;                                       /* for any_other handler */
 369           on any_other call any_other_handler ();
 370 
 371           call scheduler$find_runnable ();
 372 
 373           return;
 374 %page;
 375 /* Return the user CL intermediary for a given control point -- The user CL intermediary is invoked by
 376    cpm_cl_intermediary_ (the control point CL intermediary) before actually establishing a new command level or stopping
 377    the control point.  The user's intermediary can take whatever actions it desires and then inform the control point's
 378    intermediary either to return to the caller of cu_$cl (i.e., a "start" command) or to continue with the standard CL
 379    intermediary operation. */
 380 
 381 get_user_cl_intermediary:
 382      entry (P_control_point_id, P_user_cl_intermediary, P_code);
 383 
 384           call check_initialization ("cpm_$get_user_cl_intermediary");
 385 
 386           call find_control_point (P_control_point_id);     /* sets cpd_ptr or aborts the call entirely */
 387 
 388           P_user_cl_intermediary = control_point_data.user_cl_intermediary;
 389 
 390           P_code = 0;                                       /* success */
 391 
 392           return;
 393 
 394 
 395 
 396 /* Set the user CL intermediary for a given control point -- See the get_user_cl_intermediary entrypoint for a description
 397    of this feature. */
 398 
 399 set_user_cl_intermediary:
 400      entry (P_control_point_id, P_user_cl_intermediary, P_code);
 401 
 402           call check_initialization ("cpm_$set_user_cl_intermediary");
 403 
 404           call find_control_point (P_control_point_id);     /* sets cpd_ptr or aborts the call entirely */
 405 
 406           control_point_data.user_cl_intermediary = P_user_cl_intermediary;
 407 
 408           P_code = 0;                                       /* success */
 409 
 410           return;
 411 
 412 
 413 
 414 /* A "null" entry variable which should never be called -- Used as the initial value for user's CL intermediarys */
 415 
 416 nulle:
 417      entry () options (variable);
 418 
 419           call sub_err_ (error_table_$badcall, cpm_data_$subsystem_name, ACTION_CANT_RESTART, null (), 0,
 420                "The ""null"" entry value can not be invoked.");
 421 %page;
 422 /* Generate a call to the supplied user program in another control point */
 423 
 424 generate_call:                                              /* ... run it immediately */
 425      entry (P_control_point_id, P_userproc, P_userproc_info_ptr, P_code);
 426 
 427           generate_call_flags = CPM_GC_FORCE_READY;
 428           go to BEGIN_GENERATE_CALL;
 429 
 430 
 431 generate_call_preferred:                                    /* ... run it immediately as the preferred control point */
 432      entry (P_control_point_id, P_userproc, P_userproc_info_ptr, P_code);
 433 
 434           generate_call_flags = CPM_GC_FORCE_READY | CPM_GC_PUSH_PREFERRED;
 435           go to BEGIN_GENERATE_CALL;
 436 
 437 
 438 generate_call_when_ready:                                   /* ... run it when it next becomes READY */
 439      entry (P_control_point_id, P_userproc, P_userproc_info_ptr, P_code);
 440 
 441           generate_call_flags = ""b;
 442           go to BEGIN_GENERATE_CALL;
 443 
 444 
 445 BEGIN_GENERATE_CALL:
 446           call check_initialization ("cpm_$generate_call");
 447 
 448           call find_control_point (P_control_point_id);     /* sets cpd_ptr or aborts the call entirely */
 449 
 450           mask = ""b;                                       /* for any_other handler */
 451           on any_other call any_other_handler ();
 452 
 453 
 454           if current_cpd_ptr = cpd_ptr
 455           then do;
 456 
 457 /* The call is to take place in this control point -- Invoke the user's program directly but first place the control point
 458    into the same state as it would be in after releasing control via the scheduler.  This action is necessary to insure
 459    that cpm_overseer_$generate_call will operate correctly.  See the internal procedure switch_control_points for an
 460    explanation of the various operations performed here. */
 461 
 462                     call mask_ips_interrupts (mask);        /* can't be interrupted */
 463                     current_control_point_data.ips_mask = mask;
 464 
 465                     current_control_point_data.privileges = get_privileges_ ();
 466                     call cu_$get_cl_intermediary (current_control_point_data.cl_intermediary);
 467 
 468                     if current_control_point_data.swapped_switches
 469                          | different_switches (current_cpd_ptr, cpm_data_$previous_control_point)
 470                     then call save_io_switches ();          /* save when cpm_overseer_$generate_call expects to restore */
 471 
 472                     if trace_$transaction_begin (1)         /* disable tracing temporarily */
 473                     then ;
 474 
 475                     unspec (userproc_arg_list.header) = ""b;/* setup the argument list for the user's procedure */
 476                     userproc_arg_list.header.call_type = Interseg_call_type;
 477                     userproc_arg_list.header.arg_count = 1;
 478                     userproc_arg_list.arg_ptrs (1) = addr (P_userproc_info_ptr);
 479 
 480                     call cpm_overseer_$generate_call (addr (generate_call_flags), P_userproc, addr (userproc_arg_list));
 481                                                             /* make the call */
 482 
 483                     if trace_$transaction_end (1)           /* turn tracing back on */
 484                     then ;
 485 
 486                     if current_control_point_data.swapped_switches
 487                          | different_switches (current_cpd_ptr, cpm_data_$previous_control_point)
 488                     then call restore_io_switches ();       /* restore our switches if we saved them above */
 489 
 490                     call cu_$set_cl_intermediary (current_control_point_data.cl_intermediary);
 491                     call restore_privileges ();             /* put our privileges and CL intermediary back */
 492 
 493                     mask = current_control_point_data.ips_mask;
 494                     call unmask_ips_interrupts (mask);      /* allow IPS interrupts again */
 495                end;
 496 
 497 
 498           else do;
 499 
 500 /* The call is to take place in some other control point -- Push the necessary frame on its stack and run it immediately
 501    if requested.  If we do schedule it immediately, we must also temporarily change this control point's state to READY so
 502    that, after the other control point finishes or blocks, this control point will be able to run and clean up the stack
 503    frames associated with this generate_call. */
 504 
 505                     call push_call_frame (cpm_alm_$call_generate_call, generate_call_flags, P_userproc,
 506                          P_userproc_info_ptr);
 507 
 508                     if generate_call_flags & CPM_GC_FORCE_READY
 509                     then do;                                /* run the other control point right now */
 510                               prior_state = current_control_point_data.state;
 511 
 512                               if current_control_point_data.state ^= CPM_READY
 513                               then do;                      /* ... must make the current control point READY */
 514                                         target_cpd_ptr = cpd_ptr;
 515                                         cpd_ptr = current_cpd_ptr;
 516                                         call update_state (CPM_READY);
 517                                         cpd_ptr = target_cpd_ptr;
 518                                    end;
 519 
 520                               /*** A cleanup handler to restore the current control point state isn't necessary because,
 521                                    if a non-local goto occurs, it can only have happened while this control point was
 522                                    ready and, if we were blocked, we are about to punt the call to ipc_$block which put us
 523                                    into that state. */
 524 
 525                               call scheduler$run_specific_control_point ();
 526 
 527                               if prior_state ^= CPM_READY
 528                               then do;                      /* ... put the current control point back */
 529                                         cpd_ptr = current_cpd_ptr;
 530                                         call update_state (prior_state);
 531                                    end;
 532                          end;
 533                end;
 534 
 535           P_code = 0;                                       /* success */
 536 
 537           return;
 538 %page;
 539 /* Return the identity of the currently preferred control point -- The preferred control point is always given priority
 540    over all others whenever it is ready.  In addition, cu_$cl will actually only invoke a new control point when called in
 541    the preferred control point. */
 542 
 543 get_preferred_control_point:
 544      entry () returns (bit (36) aligned);
 545 
 546           call check_initialization ("cpm_$get_preferred_control_point");
 547 
 548           if cpm_data_$preferred_control_point ^= null ()
 549           then return (cpm_data_$preferred_control_point -> control_point_data.id);
 550           else return ((36)"0"b);                           /* none at present */
 551 
 552 
 553 
 554 /* Set the preferred control point to the specified control point iff it isn't STOPPED */
 555 
 556 set_preferred_control_point:
 557      entry (P_control_point_id, P_code);
 558 
 559           call check_initialization ("cpm_$set_preferred_control_point");
 560 
 561           call find_control_point (P_control_point_id);     /* sets cpd_ptr or aborts the entire call */
 562           if control_point_data.state = CPM_STOPPED
 563           then do;
 564                     P_code = cpm_et_$preferred_cant_be_stopped;
 565                     return;
 566                end;
 567 
 568           mask = ""b;                                       /* for any_other handler */
 569           on any_other call any_other_handler ();
 570 
 571           if cpm_data_$preferred_control_point ^= cpd_ptr
 572           then do;                                          /* actually switching control points */
 573                     call mask_ips_interrupts (mask);
 574                     call switch_preferred_control_points ();
 575                     call unmask_ips_interrupts (mask);
 576                end;
 577 
 578           P_code = 0;                                       /* success */
 579 
 580           return;
 581 %page;
 582 /* Push the preferred control point -- Saves the current preferred control point on the top of the stack and makes the
 583    specified control point preferred.  If a control point is actually pushed, the P_pushed_preferred_control_point
 584    parameter will be set.  That parameter must be used in subsequent calls to pop the stack. */
 585 
 586 push_preferred_control_point:
 587      entry (P_control_point_id, P_pushed_preferred_control_point, P_code);
 588 
 589           call check_initialization ("cpm_$push_preferred_control_point");
 590 
 591           P_pushed_preferred_control_point = "0"b;          /* initialize this parameter for cleanup handlers */
 592 
 593           call find_control_point (P_control_point_id);     /* sets cpd_ptr or aborts the entire call */
 594           if control_point_data.state = CPM_STOPPED
 595           then do;
 596                     P_code = cpm_et_$preferred_cant_be_stopped;
 597                     return;
 598                end;
 599 
 600           if cpm_data_$preferred_control_point_stack.stack_depth
 601                = hbound (cpm_data_$preferred_control_point_stack.cpd_ptr_stack, 1)
 602           then do;                                          /* the stack is already full */
 603                     P_code = cpm_et_$preferred_stack_overflow;
 604                     return;
 605                end;
 606 
 607           mask = ""b;                                       /* for any_other handler */
 608           on any_other call any_other_handler ();
 609 
 610           if cpm_data_$preferred_control_point ^= cpd_ptr
 611           then do;                                          /* we're actually switching preferred control points */
 612 
 613                     call mask_ips_interrupts (mask);
 614 
 615                     cpm_data_$preferred_control_point_stack.stack_depth, stack_idx =
 616                          cpm_data_$preferred_control_point_stack.stack_depth + 1;
 617 
 618                     cpm_data_$preferred_control_point_stack.cpd_ptr_stack (stack_idx) = cpm_data_$preferred_control_point;
 619 
 620                     call switch_preferred_control_points ();
 621 
 622                     P_pushed_preferred_control_point = "1"b;
 623 
 624                     call unmask_ips_interrupts (mask);
 625                end;
 626 
 627           P_code = 0;                                       /* success */
 628 
 629           return;
 630 %page;
 631 /* Pop the preferred control point stack by making the top of the stack the new preferred control point if and only if
 632    the P_pushed_preferred_control_point parameter is "1"b. */
 633 
 634 pop_preferred_control_point:
 635      entry (P_pushed_preferred_control_point);
 636 
 637           call check_initialization ("cpm_$pop_preferred_control_point");
 638 
 639           mask = ""b;                                       /* for any_other handler */
 640           on any_other call any_other_handler ();
 641 
 642           if P_pushed_preferred_control_point               /* the caller did push it */
 643           then do;
 644 
 645                     call mask_ips_interrupts (mask);
 646 
 647                     P_pushed_preferred_control_point = "0"b;/* once is enough, thank you */
 648 
 649                     if cpm_data_$preferred_control_point_stack.stack_depth > 0
 650                     then do;                                /* and there's something on the stack */
 651                               stack_idx = cpm_data_$preferred_control_point_stack.stack_depth;
 652                               cpm_data_$preferred_control_point_stack.stack_depth = stack_idx - 1;
 653 
 654                               cpd_ptr = cpm_data_$preferred_control_point_stack.cpd_ptr_stack (stack_idx);
 655 
 656                               call switch_preferred_control_points ();
 657                          end;
 658 
 659                     call unmask_ips_interrupts (mask);
 660                end;
 661 
 662           return;
 663 %page;
 664 /* Return the usage meters recorded for a given control point */
 665 
 666 get_control_point_meters:
 667      entry (P_control_point_id, P_cpma_ptr, P_code);
 668 
 669           call check_initialization ("cpm_$get_control_point_meters");
 670 
 671           cpma_ptr = P_cpma_ptr;
 672           if control_point_meters_argument.version ^= CONTROL_POINT_METERS_ARGUMENT_VERSION_1
 673           then do;
 674                     P_code = error_table_$unimplemented_version;
 675                     return;
 676                end;
 677 
 678           call find_control_point (P_control_point_id);     /* sets cpd_ptr or aborts the entire call */
 679 
 680           mask = ""b;                                       /* for any_other handler */
 681           on any_other call any_other_handler ();
 682 
 683           call update_meters (current_control_point_data.meters, (0));
 684                                                             /* insure that all usage values are up-to-date */
 685 
 686           control_point_meters_argument.meters = control_point_data.meters;
 687           control_point_meters_argument.number_wanted, control_point_meters_argument.number_can_return =
 688                MAX_NUMBER_OF_METERS;
 689 
 690           P_code = 0;                                       /* success */
 691 
 692           return;
 693 
 694 
 695 
 696 /* Return the usage meters recorded for the control point scheduler */
 697 
 698 get_scheduler_meters:
 699      entry (P_cpma_ptr, P_code);
 700 
 701           call check_initialization ("cpm_$get_scheduler_meters");
 702 
 703           cpma_ptr = P_cpma_ptr;
 704           if control_point_meters_argument.version ^= CONTROL_POINT_METERS_ARGUMENT_VERSION_1
 705           then do;
 706                     P_code = error_table_$unimplemented_version;
 707                     return;
 708                end;
 709 
 710           control_point_meters_argument.meters = cpm_data_$global_meters.overhead;
 711           control_point_meters_argument.number_wanted, control_point_meters_argument.number_can_return =
 712                MAX_NUMBER_OF_METERS;
 713 
 714           P_code = 0;                                       /* success */
 715 
 716           return;
 717 %page;
 718 /* Validate that control point management is enabled */
 719 
 720 check_initialization:
 721      procedure (p_entrypoint_name);
 722 
 723 dcl       p_entrypoint_name   character (*) parameter;
 724 
 725           if stackbaseptr () -> stack_header.cpm_enabled    /* we are on: find the current control point's definition */
 726           then current_cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr;
 727 
 728           else call sub_err_ (error_table_$out_of_sequence, cpm_data_$subsystem_name, ACTION_CANT_RESTART, null (), 0,
 729                     "At least one call to cpm_$create must preceed any call to ^a.", p_entrypoint_name);
 730 
 731           return;
 732 
 733      end check_initialization;
 734 
 735 
 736 
 737 /* Find the control_point_data for the request control point or abort the call completely */
 738 
 739 find_control_point:
 740      procedure (p_control_point_id);
 741 
 742 dcl       p_control_point_id  bit (36) aligned parameter;
 743 
 744           string (decoded_control_point_id) = p_control_point_id;
 745 
 746           if cpm_data_$valid_control_points.map (binary (decoded_control_point_id.stack_segno, 18, 0))
 747           then do;                                          /* the given ID does identify a valid stack */
 748                     cpd_ptr = baseptr (decoded_control_point_id.stack_segno) -> stack_header.cpm_data_ptr;
 749                     if control_point_data.id = p_control_point_id
 750                     then return;                            /* and the stack does indeed belong to that control point */
 751                end;
 752 
 753           /*** Control arrives here iff the supplied control point ID is invalid */
 754           P_code = cpm_et_$control_point_not_found;
 755           go to ERROR_RETURN_FROM_CPM_;
 756 
 757      end find_control_point;
 758 %page;
 759 /* Mask all IPS interrupts */
 760 
 761 mask_ips_interrupts:
 762      procedure (p_mask);
 763 
 764 dcl       p_mask              bit (36) aligned parameter;
 765 
 766           call hcs_$set_ips_mask (""b, p_mask);
 767 
 768      end mask_ips_interrupts;
 769 
 770 
 771 /* Invoke mask_ips_interrupts -- This entrypoint exists to prevent making the mask_ips_interrupts internal procedure
 772    non-quick by invoking it from within an on unit or other non-quick procedure. */
 773 
 774 mask_ips_interrupts_caller:
 775      entry (P_mask);
 776 
 777           call mask_ips_interrupts (P_mask);
 778           return;
 779 
 780 
 781 
 782 /* Restore the IPS mask to its state prior to calling mask_ips_interrupts */
 783 
 784 unmask_ips_interrupts:
 785      procedure (p_mask);
 786 
 787 dcl       p_mask              bit (36) aligned parameter;
 788 
 789           if substr (p_mask, 36, 1) = "1"b
 790           then call hcs_$reset_ips_mask (p_mask, p_mask);
 791 
 792      end unmask_ips_interrupts;
 793 
 794 
 795 /* Invoke unmask_ips_interrupts -- This entrypoint exists to prevent making the unmask_ips_interrupts internal procedure
 796    non-quick by invoking it from within an on unit or other non-quick procedure. */
 797 
 798 unmask_ips_interrupts_caller:
 799      entry (P_mask);
 800 
 801           call unmask_ips_interrupts (P_mask);
 802           return;
 803 
 804 
 805 
 806 /* The any_other handler established whenever we have masked IPS signals */
 807 
 808 any_other_handler:
 809      procedure ();
 810 
 811           call unmask_ips_interrupts_caller (mask);
 812 
 813           call continue_to_signal_ ((0));                   /* be sure the error gets through */
 814 
 815      end any_other_handler;
 816 %page;
 817 /* Restore the current control point's system privileges -- We need not worry about access to system_privilege_ as we only
 818    call it when we actually discover that a privilege has changed and the only way to change privileges is to use the
 819    system_privilege_ gate itself. */
 820 
 821 restore_privileges:
 822      procedure ();
 823 
 824 dcl       current_privileges  bit (36) aligned;
 825 
 826           current_privileges = get_privileges_ ();
 827 
 828           if current_control_point_data.privileges = current_privileges
 829           then return;                                      /* privileges are already correct */
 830 
 831           if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$comm_privilege
 832           then if current_control_point_data.privileges & sys_info$comm_privilege
 833                then call system_privilege_$comm_priv_on ((0));
 834                else call system_privilege_$comm_priv_off ((0));
 835 
 836           if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$dir_privilege
 837           then if current_control_point_data.privileges & sys_info$dir_privilege
 838                then call system_privilege_$dir_priv_on ((0));
 839                else call system_privilege_$dir_priv_off ((0));
 840 
 841           if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$ipc_privilege
 842           then if current_control_point_data.privileges & sys_info$ipc_privilege
 843                then call system_privilege_$ipc_priv_on ((0));
 844                else call system_privilege_$ipc_priv_off ((0));
 845 
 846           if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$rcp_privilege
 847           then if current_control_point_data.privileges & sys_info$rcp_privilege
 848                then call system_privilege_$rcp_priv_on ((0));
 849                else call system_privilege_$rcp_priv_off ((0));
 850 
 851           if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$ring1_privilege
 852           then if current_control_point_data.privileges & sys_info$ring1_privilege
 853                then call system_privilege_$ring1_priv_on ((0));
 854                else call system_privilege_$ring1_priv_off ((0));
 855 
 856           if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$seg_privilege
 857           then if current_control_point_data.privileges & sys_info$seg_privilege
 858                then call system_privilege_$seg_priv_on ((0));
 859                else call system_privilege_$seg_priv_off ((0));
 860 
 861           if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$soos_privilege
 862           then if current_control_point_data.privileges & sys_info$soos_privilege
 863                then call system_privilege_$soos_priv_on ((0));
 864                else call system_privilege_$soos_priv_off ((0));
 865 
 866           return;
 867 
 868      end restore_privileges;
 869 %page;
 870 /* Save the current control point's standard I/O switches -- Always called with all IPS signals masked */
 871 
 872 save_io_switches:
 873      procedure ();
 874 
 875           if current_control_point_data.swapped_switches
 876           then ios_ptr = addr (cpm_data_$root_control_point_data.io_switches);
 877           else ios_ptr = addr (current_control_point_data.io_switches);
 878 
 879           call iox_$move_attach (iox_$user_io, io_switches.user_io, (0));
 880           call iox_$move_attach (iox_$user_input, io_switches.user_input, (0));
 881           call iox_$move_attach (iox_$user_output, io_switches.user_output, (0));
 882           call iox_$move_attach (iox_$error_output, io_switches.error_output, (0));
 883 
 884           return;
 885 
 886      end save_io_switches;
 887 
 888 
 889 /* Restore the current control point's standard I/O switches -- Always called with all IPS signals masked */
 890 
 891 restore_io_switches:
 892      procedure ();
 893 
 894           if current_control_point_data.swapped_switches
 895           then ios_ptr = addr (cpm_data_$root_control_point_data.io_switches);
 896           else ios_ptr = addr (current_control_point_data.io_switches);
 897 
 898           call iox_$move_attach (io_switches.user_io, iox_$user_io, (0));
 899           call iox_$move_attach (io_switches.user_input, iox_$user_input, (0));
 900           call iox_$move_attach (io_switches.user_output, iox_$user_output, (0));
 901           call iox_$move_attach (io_switches.error_output, iox_$error_output, (0));
 902 
 903           return;
 904 
 905      end restore_io_switches;
 906 
 907 
 908 
 909 /* Determines if the two specified control points use different sets of standard I/O switches */
 910 
 911 different_switches:
 912      procedure (p_cpd_1_ptr, p_cpd_2_ptr) returns (bit (1) aligned);
 913 
 914 dcl       1 cpd_1             like control_point_data aligned based (p_cpd_1_ptr);
 915 dcl       1 cpd_2             like control_point_data aligned based (p_cpd_2_ptr);
 916 dcl       (p_cpd_1_ptr, p_cpd_2_ptr)
 917                               pointer parameter;
 918 
 919           if cpd_1.swapped_switches & cpd_2.swapped_switches
 920           then return ("0"b);                               /* both control points are using the root's switches */
 921 
 922           else if cpd_1.group_id = cpd_2.group_id           /* same group: they use the same switches ... */
 923           then return (cpd_1.swapped_switches ^= cpd_2.swapped_switches);
 924                                                             /* ... unless one is using the root's but not the other */
 925 
 926           else if (cpd_1.swapped_switches & (cpd_2.group_id = cpm_data_$root_control_point_data.group_id))
 927                | (cpd_2.swapped_switches & (cpd_1.group_id = cpm_data_$root_control_point_data.group_id))
 928           then return ("0"b);                               /* different groups: but one is swapped to the other */
 929 
 930           else return ("1"b);                               /* different groups really using different switches */
 931 
 932      end different_switches;
 933 %page;
 934 /* The control point scheduler */
 935 
 936 scheduler:
 937      procedure ();
 938           return;                                           /* not used */
 939 
 940 
 941 /* Run the control point at the top of the ready queue -- If there are no ready control points, wait for an IPC event to
 942    make one or more control points eligible. */
 943 
 944 scheduler$find_runnable:
 945      entry ();
 946 
 947           call update_meters (current_control_point_data.meters, cpm_data_$global_meters.overhead.n_schedules);
 948 
 949           if cpm_data_$ready_queue.first = null ()
 950           then do;                                          /* nothing ready at present */
 951                     if (current_cpd_ptr ^= cpm_data_$preferred_control_point)
 952                          & (cpm_data_$preferred_control_point ^= null ())
 953                     then if cpm_data_$preferred_control_point -> control_point_data.state = CPM_BLOCKED
 954                          then do;                           /* ... preferred is blocked: better to hcs_$block in it */
 955                                    cpd_ptr = cpm_data_$preferred_control_point;
 956                                    call switch_control_points ();
 957                               end;
 958                     do while (cpm_data_$ready_queue.first = null ());
 959                          call ipc_$wait_for_an_event ();    /* ... we are preferred or he's not blocked: hcs_$block */
 960                     end;
 961                end;
 962 
 963           cpd_ptr = cpm_data_$ready_queue.first;            /* run whoever's on top */
 964 
 965           call switch_control_points ();                    /* THUNK! */
 966 
 967           if cpm_data_$gc_control_points                    /* there are control points we can eliminate */
 968           then call gc_dead_control_points ();
 969 
 970           call update_meters (cpm_data_$global_meters.overhead, current_control_point_data.meters.n_schedules);
 971 
 972           return;
 973 
 974 
 975 
 976 /* Run the selected control point */
 977 
 978 scheduler$run_specific_control_point:
 979      entry ();
 980 
 981           call update_meters (current_control_point_data.meters, cpm_data_$global_meters.overhead.n_schedules);
 982 
 983           call switch_control_points ();                    /* THUNK! */
 984 
 985           if cpm_data_$gc_control_points                    /* there are control points we can eliminate */
 986           then call gc_dead_control_points ();
 987 
 988           call update_meters (cpm_data_$global_meters.overhead, current_control_point_data.meters.n_schedules);
 989 
 990           return;
 991 %page;
 992 /* Actual code to switch from one control point to another */
 993 
 994 switch_control_points:
 995      procedure ();
 996 
 997           if current_cpd_ptr = cpd_ptr                      /* asked to run ourselves -- nothing to do */
 998           then return;
 999 
1000           call mask_ips_interrupts (mask);                  /* can't be interrupted during this process */
1001 
1002 
1003 /* Save the present IPS mask, system privileges, and CL intermediary in the control point's definition -- Each control
1004    point is permitted to manipulate these per-process values as if it were the only control point in the process.
1005    Therefore, we must save and restore these values whenever we switch control points to insure that each control point's
1006    settings of these mechansims will be undisturbed by other control points */
1007 
1008           current_control_point_data.ips_mask = mask;
1009 
1010           current_control_point_data.privileges = get_privileges_ ();
1011 
1012           call cu_$get_cl_intermediary (current_control_point_data.cl_intermediary);
1013 
1014 
1015 /* Save our standard I/O switches if they are not the same set as used by the control point about to be run */
1016 
1017           if different_switches (current_cpd_ptr, cpd_ptr)
1018           then call save_io_switches ();
1019 
1020 
1021 /* Switch Stacks -- We must inform inform ring-0 of the change so it will properly signal faults, IPS interrupts, etc. */
1022 
1023           cpm_data_$previous_control_point = current_cpd_ptr;
1024 
1025           if trace_$transaction_begin (1)                   /* disable tracing -- let the new control point ... */
1026           then ;                                            /* ... reenable it if appropriate */
1027 
1028           call hcs_$set_stack_ptr (control_point_data.stack_ptr);
1029 
1030           call cpm_alm_$switch_stacks (control_point_data.stack_ptr);
1031 
1032           /*** Immediately after the above call, control returns to this point in the new control point we chose to run.
1033                Consequently, current_control_point_data now refers to the control point referenced above as
1034                control_point_data and the control point referenced above as current_control_point_data is now referenced
1035                through cpm_data_$previous_control_point. */
1036 
1037           if trace_$transaction_end (1)                     /* reenable tracing if it was running in this control point */
1038           then ;
1039 
1040 
1041 /* Restore our I/O switches */
1042 
1043           if different_switches (current_cpd_ptr, cpm_data_$previous_control_point)
1044           then call restore_io_switches ();
1045 
1046 
1047 /* Restore our saved CL intermediary, system privileges, and IPS mask */
1048 
1049           call cu_$set_cl_intermediary (current_control_point_data.cl_intermediary);
1050 
1051           call restore_privileges ();
1052 
1053           mask = current_control_point_data.ips_mask;
1054           call unmask_ips_interrupts (mask);                /* let IPS through again */
1055 
1056           return;
1057 
1058      end switch_control_points;
1059 %page;
1060 /* Finish the destruction of any dead control points */
1061 
1062 gc_dead_control_points:
1063      procedure ();
1064 
1065           system_area_ptr = get_system_free_area_ ();       /* needed by destroy_control_point */
1066 
1067           call gc_worker (addr (cpm_data_$root_control_point_data));
1068 
1069           cpm_data_$gc_control_points = "0"b;               /* we've done all we can for now */
1070 
1071           return;
1072 
1073 
1074 
1075 /* Actually walks the tree of control points looking for those which can be eliminated */
1076 
1077 gc_worker:
1078      procedure (p_cpd_ptr) recursive;
1079 
1080 dcl       1 p_control_point_data
1081                               like control_point_data aligned based (p_cpd_ptr);
1082 dcl       p_cpd_ptr           pointer parameter;
1083 
1084 dcl       1 a_control_point_data
1085                               like control_point_data aligned based (a_cpd_ptr);
1086 dcl       a_cpd_ptr           pointer;
1087 
1088 dcl       next_cpd_ptr        pointer;
1089 
1090           /*** Walk the control point's list of children and flush any of them that are dead */
1091           do a_cpd_ptr = p_control_point_data.first_child repeat (next_cpd_ptr) while (a_cpd_ptr ^= null ());
1092                next_cpd_ptr = a_control_point_data.next_peer;
1093                call gc_worker (a_cpd_ptr);
1094           end;
1095 
1096           /*** If this control point is dead and has no children, eliminate it */
1097           if (p_control_point_data.state = CPM_DESTROYED) & (p_control_point_data.first_child = null ())
1098           then call destroy_control_point (p_cpd_ptr);
1099 
1100           return;
1101 
1102      end gc_worker;
1103 
1104      end gc_dead_control_points;
1105 
1106      end scheduler;
1107 %page;
1108 /* Update the meters for a given control point or for the scheduler itself */
1109 
1110 update_meters:
1111      procedure (p_meters, p_n_schedules);
1112 
1113 dcl       1 p_meters          like control_point_meters aligned parameter;
1114 dcl       p_n_schedules       fixed binary parameter;
1115 
1116 dcl       1 local_usage       like process_usage aligned;
1117 dcl       local_real_time     fixed binary (71);
1118 
1119           local_real_time = clock ();                       /* to compute real-time change */
1120 
1121           local_usage.number_wanted = MAX_NUMBER_OF_METERS; /* get all the meters */
1122           call hcs_$get_process_usage (addr (local_usage), (0));
1123 
1124           call mask_ips_interrupts (mask);                  /* update them uniterruptably */
1125 
1126           p_n_schedules = p_n_schedules + 1;                /* count the scheduling */
1127 
1128           p_meters.real_time = p_meters.real_time + local_real_time - cpm_data_$global_meters.last_meters.real_time;
1129           p_meters.usage = p_meters.usage + local_usage - cpm_data_$global_meters.last_meters.usage;
1130 
1131           cpm_data_$global_meters.last_meters.real_time = local_real_time;
1132           cpm_data_$global_meters.last_meters.usage = local_usage;
1133 
1134           call unmask_ips_interrupts (mask);
1135 
1136           return;
1137 
1138      end update_meters;
1139 %page;
1140 /* Changes the state of a control point */
1141 
1142 update_state:
1143      procedure (p_new_state);
1144 
1145 dcl       p_new_state         fixed binary parameter;
1146 
1147           if p_new_state = control_point_data.state         /* the control point is already in the requested state */
1148           then return;
1149 
1150           call mask_ips_interrupts (mask);
1151 
1152           if control_point_data.preferred & ((p_new_state = CPM_DESTROYED) | (p_new_state = CPM_STOPPED))
1153           then do;                                          /* only READY or BLOCKED control points can be preferred */
1154                     call set_preferred_control_point (cpm_data_$root_control_point_data.id, (0));
1155                end;                                         /* ... so try to switch it to the root control point */
1156 
1157           if control_point_data.state = CPM_READY           /* it's about to become not ready: remove it from the queue */
1158           then call remove_from_ready_queue ();
1159 
1160           control_point_data.state = p_new_state;
1161 
1162           if control_point_data.state = CPM_READY           /* it's been made ready: stick it into the ready queue */
1163           then call insert_into_ready_queue ();
1164 
1165           else if control_point_data.state = CPM_DESTROYED  /* it's been killed */
1166           then do;
1167                     call ipc_$reassign_call_channels (control_point_data.id, parent_control_point_data.id);
1168                     string (decoded_control_point_id) = control_point_data.id;
1169                     cpm_data_$valid_control_points.map (binary (decoded_control_point_id.stack_segno, 18, 0)) = "0"b;
1170                     cpm_data_$gc_control_points = "1"b;     /* ... we need to cleanup when next possible */
1171                     cpm_data_$n_control_points = cpm_data_$n_control_points - 1;
1172                end;
1173 
1174           call unmask_ips_interrupts (mask);
1175 
1176           return;
1177 
1178      end update_state;
1179 
1180 
1181 
1182 /* Invoke update_state -- Called by cpm_overseer_$generate_call */
1183 
1184 update_state_caller:
1185      entry (P_cpd_ptr, P_new_state);
1186 
1187           mask = ""b;                                       /* for any_other handler */
1188           on any_other call any_other_handler ();
1189 
1190           cpd_ptr = P_cpd_ptr;
1191 
1192           call update_state (P_new_state);
1193 
1194           return;
1195 %page;
1196 /* Sets the preferred control point -- Rethreads the ready queue to reflect the change in priority of the old and new
1197    preferred control points */
1198 
1199 switch_preferred_control_points:
1200      procedure ();
1201 
1202 dcl       old_preferred_cpd_ptr
1203                               pointer;
1204 
1205           control_point_data.preferred = "1"b;              /* this control point is now preferred */
1206 
1207           if control_point_data.state = CPM_READY
1208           then do;                                          /* it's ready: rethread it to the top of the queue */
1209                     call remove_from_ready_queue ();
1210                     call insert_into_ready_queue ();
1211                end;
1212 
1213 
1214 /* Actually switch preferred control points */
1215 
1216           old_preferred_cpd_ptr = cpm_data_$preferred_control_point;
1217 
1218           cpm_data_$preferred_control_point = cpd_ptr;      /* establish the new preferred control point */
1219 
1220           cpd_ptr = old_preferred_cpd_ptr;
1221 
1222 
1223 /* control_point_data now refers to the old preferred control point */
1224 
1225           control_point_data.preferred = "0"b;              /* it's no longer special */
1226 
1227           if control_point_data.state = CPM_READY
1228           then do;                                          /* rethread to reflect its lowered priority */
1229                     call remove_from_ready_queue ();
1230                     call insert_into_ready_queue ();
1231                end;
1232 
1233           return;
1234 
1235      end switch_preferred_control_points;
1236 %page;
1237 /* Inserts a control point into the ready queue -- This procedure expects its caller to have masked IPS interrupts. */
1238 
1239 insert_into_ready_queue:
1240      procedure ();
1241 
1242 dcl       (prev_cpd_ptr, next_cpd_ptr)
1243                               pointer;
1244 
1245           prev_cpd_ptr = null ();                           /* assume it goes at the beginning of the queue */
1246           next_cpd_ptr = cpm_data_$ready_queue.first;
1247 
1248           if control_point_data.preferred                   /* it should always have first priority */
1249           then go to INSERT_INTO_THE_LIST;
1250 
1251           do next_cpd_ptr = cpm_data_$ready_queue.first repeat (next_cpd_ptr -> control_point_data.next_ready)
1252                while (next_cpd_ptr ^= null ());
1253                if (next_cpd_ptr -> control_point_data.priority > control_point_data.priority)
1254                     & ^next_cpd_ptr -> control_point_data.preferred
1255                then go to INSERT_INTO_THE_LIST;             /* next one is lower priority and not preferred */
1256                else prev_cpd_ptr = next_cpd_ptr;
1257           end;                                              /* add to the end of the queue if we fall through */
1258 
1259 INSERT_INTO_THE_LIST:
1260           if prev_cpd_ptr = null ()                         /* put it at the top of the queue */
1261           then cpm_data_$ready_queue.first = cpd_ptr;
1262           else prev_cpd_ptr -> control_point_data.next_ready = cpd_ptr;
1263 
1264           if next_cpd_ptr = null ()                         /* put it at the end of the queue */
1265           then cpm_data_$ready_queue.last = cpd_ptr;
1266           else next_cpd_ptr -> control_point_data.prev_ready = cpd_ptr;
1267 
1268           control_point_data.prev_ready = prev_cpd_ptr;
1269           control_point_data.next_ready = next_cpd_ptr;
1270 
1271           return;
1272 
1273      end insert_into_ready_queue;
1274 
1275 
1276 
1277 /* Removes a control point from the ready queue -- This procedure expects its caller to have masked IPS interrupts. */
1278 
1279 remove_from_ready_queue:
1280      procedure ();
1281 
1282           if control_point_data.prev_ready = null ()        /* we are at the top of the queue */
1283           then cpm_data_$ready_queue.first = control_point_data.next_ready;
1284           else control_point_data.prev_ready -> control_point_data.next_ready = control_point_data.next_ready;
1285 
1286           if control_point_data.next_ready = null ()        /* we are at the bottom of the queue */
1287           then cpm_data_$ready_queue.last = control_point_data.prev_ready;
1288           else control_point_data.next_ready -> control_point_data.prev_ready = control_point_data.prev_ready;
1289 
1290           control_point_data.ready_queue = null ();         /* complete the removal process */
1291 
1292           return;
1293 
1294      end remove_from_ready_queue;
1295 %page;
1296 /* Creates a new control point */
1297 
1298 create_control_point:
1299      procedure () options (non_quick);
1300 
1301 dcl       code                fixed binary (35);
1302 
1303           if create_control_point_info.version ^= CREATE_CONTROL_POINT_INFO_VERSION_1
1304           then call create_failure (error_table_$unimplemented_version);
1305 
1306           call mask_ips_interrupts_caller (mask);           /* avoid interrupts until we can clean up properly */
1307 
1308           allocate control_point_data in (system_area) set (cpd_ptr);
1309           control_point_data.stack_ptr, control_point_data.parent, control_point_data.peers = null ();
1310 
1311           call unmask_ips_interrupts_caller (mask);         /* the cleanup handler will now work OK */
1312 
1313           call get_temp_segment_ (cpm_data_$subsystem_name, control_point_data.stack_ptr, code);
1314           if code ^= 0
1315           then call create_failure (code);
1316 
1317 
1318 /* Setup most of the control point's data */
1319 
1320           decoded_control_point_id.stack_segno = baseno (control_point_data.stack_ptr);
1321           decoded_control_point_id.unique_bits = substr (bit (clock (), 71), 54, 18);
1322           control_point_data.id = string (decoded_control_point_id);
1323 
1324           control_point_data.state = CPM_STOPPED;           /* the user must start it */
1325 
1326           control_point_data.priority = create_control_point_info.priority;
1327           control_point_data.preferred = "0"b;              /* it's an ordinary control point */
1328 
1329           control_point_data.last_frame_ptr = null ();      /* cpm_alm_$switch_stacks hasn't been used yet */
1330 
1331           if create_control_point_info.independent
1332           then control_point_data.parent = addr (cpm_data_$root_control_point_data);
1333           else control_point_data.parent = stackbaseptr () -> stack_header.cpm_data_ptr;
1334 
1335           control_point_data.peers,                         /* we haven't threaded it into any lists yet */
1336                control_point_data.children, control_point_data.ready_queue = null ();
1337 
1338           if create_control_point_info.user_cl_intermediary_given
1339           then control_point_data.user_cl_intermediary = create_control_point_info.user_cl_intermediary;
1340           else control_point_data.user_cl_intermediary = nulle;
1341 
1342           control_point_data.comment = create_control_point_info.comment;
1343 
1344           control_point_data.ips_mask = sys_info$all_valid_ips_mask;
1345           substr (control_point_data.ips_mask, 36) = "1"b;  /* start with all IPS interrupts enabled */
1346 
1347           control_point_data.privileges = ""b;              /* start with no privileges */
1348 
1349           control_point_data.cl_intermediary = cpm_overseer_$cl_intermediary;
1350                                                             /* start with the "standard" CL intermediary */
1351 
1352           control_point_data.io_switches = parent_control_point_data.io_switches;
1353           control_point_data.group_id = parent_control_point_data.group_id;
1354                                                             /* we'll share our parent's switches until we've run once */
1355 
1356           control_point_data.meters = 0;                    /* hasn't been used yet */
1357 
1358 
1359 /* Initialize the new control point's stack by copying its parent's stack header */
1360 
1361           call mask_ips_interrupts_caller (mask);           /* the rest of this operation must not be interrupted */
1362 
1363           if trace_$transaction_begin (1)
1364           then ;                                            /* new stack should have standard operator pointers */
1365 
1366           control_point_data.stack_ptr -> stack_header = parent_control_point_data.stack_ptr -> stack_header;
1367           control_point_data.stack_ptr -> stack_header.stack_begin_ptr,
1368                control_point_data.stack_ptr -> stack_header.stack_end_ptr =
1369                addwordno (control_point_data.stack_ptr, currentsize (control_point_data.stack_ptr -> stack_header));
1370 
1371           control_point_data.stack_ptr -> stack_header.cpm_data_ptr = cpd_ptr;
1372           control_point_data.stack_ptr -> stack_header.cpm_enabled = substr(control_point_data.id,1,length(stack_header.cpm_enabled));
1373 
1374           unspec (control_point_data.stack_ptr -> stack_header.trace) = ""b;
1375 
1376           if trace_$transaction_end (1)
1377           then ;
1378 
1379           control_point_data.destroy = cv_entry_to_label_ (self_destruct);
1380 
1381 
1382 /* Thread this control point into its parent's children chain */
1383 
1384           if parent_control_point_data.first_child = null ()
1385           then do;                                          /* new control point is the parent's first child */
1386                     parent_control_point_data.first_child = cpd_ptr;
1387                     control_point_data.prev_peer = null ();
1388                end;
1389           else do;                                          /* parent has several other children already */
1390                     parent_control_point_data.last_child -> control_point_data.next_peer = cpd_ptr;
1391                     control_point_data.prev_peer = parent_control_point_data.last_child;
1392                end;
1393 
1394           control_point_data.next_peer = null ();
1395           parent_control_point_data.last_child = cpd_ptr;
1396 
1397           cpm_data_$valid_control_points.map (binary (decoded_control_point_id.stack_segno, 18, 0)) = "1"b;
1398           cpm_data_$n_control_points = cpm_data_$n_control_points + 1;
1399 
1400           call unmask_ips_interrupts_caller (mask);
1401 
1402           return;
1403 
1404 
1405 
1406 /* Reports an error during control point creation to our caller */
1407 
1408 create_failure:
1409      procedure (p_code);
1410 
1411 dcl       p_code              fixed binary (35) parameter;
1412 
1413           P_code = p_code;
1414           go to ERROR_RETURN_FROM_CPM_$CREATE;
1415 
1416      end create_failure;
1417 
1418 
1419 
1420 /* Converts an entry variable into a label variable which will unwind the stack */
1421 
1422 cv_entry_to_label_:
1423      procedure (p_entry) returns (label variable);
1424 
1425 dcl       p_entry             entry variable parameter;
1426 
1427 dcl       a_label             label variable;
1428 dcl       1 a_label_decoded   aligned based (addr (a_label)),
1429             2 code_ptr        pointer,
1430             2 environment_ptr pointer;
1431 
1432           a_label_decoded.code_ptr = codeptr (p_entry);
1433           a_label_decoded.environment_ptr = control_point_data.stack_ptr -> stack_header.stack_begin_ptr;
1434                                                             /* will unwind the stack to its first frame */
1435 
1436           return (a_label);
1437 
1438      end cv_entry_to_label_;
1439 
1440      end create_control_point;
1441 %page;
1442 /* Destroys an old control point -- This procedure is only called after all the control point's children have been
1443    destroyed.  It is also called during the creation of a control point if an error occurs after the control point is
1444    partially created. */
1445 
1446 destroy_control_point:
1447      procedure (p_cpd_ptr);
1448 
1449 dcl       p_cpd_ptr           pointer parameter;
1450 
1451 dcl       1 p_control_point_data
1452                               like control_point_data aligned based (p_cpd_ptr);
1453 dcl       1 p_parent_control_point_data
1454                               like control_point_data aligned based (p_control_point_data.parent);
1455 
1456 
1457 /* Remove the dead control point from its parent's children chain */
1458 
1459           if p_control_point_data.parent ^= null ()
1460           then do;                                          /* there's a parent defined */
1461                     p_parent_control_point_data.meters = p_parent_control_point_data.meters + p_control_point_data.meters;
1462 
1463                     call mask_ips_interrupts_caller (mask); /* prevent interrupts while rechaining */
1464 
1465                     /*** Check that the parent knows of the control point before rechaining -- This check is only
1466                          necessary if the control point's peer chain pointers are null as this could indicate that the
1467                          control point hadn't been chained before it was destroyed. */
1468 
1469                     if p_control_point_data.prev_peer = null ()
1470                     then do;                                /* it might be the parent's first child */
1471                               if p_parent_control_point_data.first_child = p_cpd_ptr
1472                               then p_parent_control_point_data.first_child = p_control_point_data.next_peer;
1473                          end;
1474                     else p_control_point_data.prev_peer -> control_point_data.next_peer = p_control_point_data.next_peer;
1475 
1476                     if p_control_point_data.next_peer = null ()
1477                     then do;                                /* it might be the parent's last child */
1478                               if p_parent_control_point_data.last_child = p_cpd_ptr
1479                               then p_parent_control_point_data.last_child = p_control_point_data.prev_peer;
1480                          end;
1481                     else p_control_point_data.next_peer -> control_point_data.prev_peer = p_control_point_data.prev_peer;
1482 
1483                     p_control_point_data.parent, p_control_point_data.peers = null ();
1484                     call unmask_ips_interrupts_caller (mask);
1485                end;                                         /* the parent no longers knows about us */
1486 
1487 
1488 /* Destroy the dead control point's stack */
1489 
1490           if p_control_point_data.stack_ptr ^= null ()
1491           then do;                                          /* its stack exists */
1492                     call release_temp_segment_ (cpm_data_$subsystem_name, p_control_point_data.stack_ptr, (0));
1493                     p_control_point_data.stack_ptr = null ();
1494                end;
1495 
1496 
1497 /* Complete the destruction of the control point */
1498 
1499           free p_control_point_data in (system_area);
1500           p_cpd_ptr = null ();                              /* its destroyed */
1501 
1502           return;
1503 
1504      end destroy_control_point;
1505 %page;
1506 /* Creates a stack frame on the given stack to call the specified entrypoint --
1507 
1508    The stack frame is initialized appropriately so that, when cpm_alm_$switch_stacks returns on the new stack, the
1509    entrypoint specified by the p_caller parameter will be invoked.  As this entrypoint is invoked by a return with its
1510    stack frame already extant, it must be an ALM routine which then calls the actual PL/I caller entrypoint.  The
1511    correspondence between the ALM and PL/I procedures follows:
1512 
1513                           ALM entrypoint                          PL/I entrypoint
1514                     cpm_alm_$call_overseer                  cpm_overseer_$overseer
1515                     cpm_alm_$call_generate_call             cpm_overseer_$generate_call
1516 
1517    The PL/I entrypoint prepares the environment according to the data in the p_caller_info parameter
1518    and then invokes the entrypoint specified as the p_callee parameter passing it the p_callee_info_ptr parameter as its
1519    single parameter.  When the callee entrypoint returns, the PL/I entrypoint returns to the ALM entrypoint.  The
1520    cpm_alm_$call_cpm_overseer_ entrypoint will then transfer to cpm_$self_destruct to destroy the control point; the
1521    cpm_alm_$call_cpm_generate_call_ entrypoint will then return to the prior stack frame on the stack which is normally a
1522    frame owned by cpm_$scheduler. */
1523 
1524 push_call_frame:
1525      procedure (p_caller, p_caller_info, p_callee, p_callee_info_ptr) options (non_quick);
1526 
1527 dcl       p_caller            entry () variable parameter;
1528 dcl       p_caller_info       bit (*) aligned parameter;
1529 dcl       p_callee            entry (pointer) variable parameter;
1530 dcl       p_callee_info_ptr   pointer parameter;
1531 
1532 dcl       1 call_frame        aligned based (sp),           /* the stack frame for p_caller */
1533             2 header          like stack_frame aligned,     /* ... standard stack frame header */
1534             2 arguments,                                    /* ... arguments to either p_callee or p_caller's PL/I */
1535               3 caller_info_ptr
1536                               pointer,
1537               3 callee        entry (pointer) variable,
1538               3 callee_arg_list_ptr
1539                               pointer,
1540               3 callee_info_ptr
1541                               pointer,
1542             2 caller_arg_list,                              /* ... the argument list for p_caller's PL/I counterpart */
1543               3 header        like arg_list.header,
1544               3 arg_ptrs      (3) pointer,
1545             2 callee_arg_list,                              /* ... the argument list for p_callee */
1546               3 header        like arg_list.header,
1547               3 arg_ptrs      (1) pointer,
1548             2 caller_info     bit (length (p_caller_info)) aligned;
1549 
1550           call mask_ips_interrupts_caller (mask);           /* creating the frame must not be interrupted */
1551 
1552           sb = control_point_data.stack_ptr;                /* find the target stack ... */
1553           sp = stack_header.stack_end_ptr;                  /* ... and the place to lay down the caller frame */
1554 
1555           stack_frame.return_ptr = codeptr (p_caller);      /* where to begin execution after cpm_alm_$switch_stacks */
1556           stack_frame.translator_id = TRANSLATOR_ID_ALM;
1557 
1558           call_frame.caller_info = p_caller_info;           /* copy the parameters into the frame */
1559           call_frame.caller_info_ptr = addr (call_frame.caller_info);
1560           call_frame.callee = p_callee;
1561           call_frame.callee_info_ptr = p_callee_info_ptr;
1562 
1563           stack_frame.arg_ptr = addr (call_frame.caller_arg_list);
1564                                                             /* record where this frame's argument list may be found */
1565 
1566           unspec (call_frame.caller_arg_list.header) = ""b; /* setup the caller's argument list */
1567           call_frame.caller_arg_list.header.call_type = Interseg_call_type;
1568           call_frame.caller_arg_list.header.arg_count = 3;  /* caller_flags, callee, callee_info_ptr */
1569           call_frame.caller_arg_list.arg_ptrs (1) = addr (call_frame.caller_info_ptr);
1570           call_frame.caller_arg_list.arg_ptrs (2) = addr (call_frame.callee);
1571           call_frame.caller_arg_list.arg_ptrs (3) = addr (call_frame.callee_arg_list_ptr);
1572 
1573           call_frame.callee_arg_list_ptr = addr (call_frame.callee_arg_list);
1574                                                             /* record where the callee's argument list can be found */
1575 
1576           unspec (call_frame.callee_arg_list.header) = ""b; /* setup the callee's argument list */
1577           call_frame.callee_arg_list.header.call_type = Interseg_call_type;
1578           call_frame.callee_arg_list.header.arg_count = 1;
1579           call_frame.callee_arg_list.arg_ptrs (1) = addr (call_frame.callee_info_ptr);
1580 
1581           stack_frame.prev_sp = control_point_data.last_frame_ptr;
1582                                                             /* when this call is done: return to the scheduler */
1583 
1584           control_point_data.last_frame_ptr = sp;           /* have cpm_alm_$switch_stacks return to this new frame */
1585 
1586           stack_frame.next_sp,                              /* "push" the frame into existence */
1587                                                             /* Note that we guarantee that the next stack frame */
1588                                                             /* goes on a mod 16-word boundary. */
1589                stack_header.stack_end_ptr =
1590                addwordno (sp, (currentsize (call_frame) + 16 - mod (currentsize (call_frame), 16)));
1591 
1592           call unmask_ips_interrupts_caller (mask);
1593 
1594           return;
1595 
1596      end push_call_frame;
1597 
1598 /* format: off */
1599 %page; %include cpm_data_;
1600 %page; %include cpm_internal_data;
1601 %page; %include cpm_control_point_data;
1602 %include cpm_ctrl_pt_meters;
1603 %include process_usage;
1604 %page; %include cpm_create_ctrl_pt_info;
1605 %page; %include cpm_generate_call_flags;
1606 %page; %include stack_header;
1607 %page; %include stack_frame;
1608 %page; %include arg_list;
1609 %page; %include iox_dcls;
1610 %page; %include sub_err_flags;
1611 %page; %include trace_interface;
1612 /* format: on */
1613 
1614      end cpm_;