1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23 cpm_:
24 procedure ();
25
26 ERROR_RETURN_FROM_CPM_:
27 return;
28
29
30
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;
36
37 dcl P_user_cl_intermediary
38 entry (bit (1) aligned) variable parameter;
39
40 dcl P_userproc
41 entry (pointer) variable parameter;
42 dcl P_userproc_info_ptr pointer parameter;
43
44 dcl P_pushed_preferred_control_point
45 bit (1) aligned parameter;
46
47 dcl P_cpma_ptr pointer parameter;
48
49 dcl P_cpd_ptr pointer parameter;
50 dcl P_new_state fixed binary parameter;
51
52 dcl P_mask bit (36) aligned parameter;
53
54
55
56
57 dcl 1 current_control_point_data
58 like control_point_data aligned based (current_cpd_ptr);
59 dcl current_cpd_ptr pointer;
60
61 dcl 1 parent_control_point_data
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
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;
177 call cpm_initialize_ ();
178 current_cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr;
179 end;
180
181 ccpi_ptr = P_ccpi_ptr;
182
183 system_area_ptr = get_system_free_area_ ();
184
185 mask = ""b;
186 on any_other call any_other_handler ();
187
188 cpd_ptr = null ();
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 ();
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;
202
203 return;
204
205
206
207
208 ERROR_RETURN_FROM_CPM_$CREATE:
209 if cpd_ptr ^= null ()
210 then call destroy_control_point (cpd_ptr);
211 return;
212 %page;
213
214
215
216 destroy:
217 entry (P_control_point_id, P_code);
218
219 call check_initialization ("cpm_$destroy");
220
221 call find_control_point (P_control_point_id);
222 if cpd_ptr = addr (cpm_data_$root_control_point_data)
223 then do;
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
235
236
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;
245 else call sub_err_ (cpm_et_$cant_destroy_root, cpm_data_$subsystem_name, ACTION_CANT_RESTART, null (), 0);
246
247
248
249
250
251
252
253 self_destruct:
254 entry ();
255
256 current_cpd_ptr, cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr;
257
258 mask = ""b;
259 on any_other call any_other_handler ();
260
261 call update_state (CPM_DESTROYED);
262
263 do while ("1"b);
264 call scheduler$find_runnable ();
265 end;
266 %page;
267
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);
275
276 mask = ""b;
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;
283 end;
284
285 else P_code = cpm_et_$already_started;
286
287 return;
288
289
290
291
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);
299 if cpd_ptr = addr (cpm_data_$root_control_point_data)
300 then do;
301 P_code = cpm_et_$cant_stop_root;
302 return;
303 end;
304
305 mask = ""b;
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;
312 end;
313
314 else P_code = cpm_et_$already_stopped;
315
316 return;
317 %page;
318
319
320 block:
321 entry ();
322
323 call check_initialization ("cpm_$block");
324 cpd_ptr = current_cpd_ptr;
325
326 mask = ""b;
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
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);
344
345 mask = ""b;
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;
352 end;
353
354 else if control_point_data.state = CPM_READY
355 then P_code = cpm_et_$wakeup_ignored;
356
357 else P_code = cpm_et_$cant_wakeup_when_stopped;
358
359 return;
360 %page;
361
362
363 scheduler:
364 entry ();
365
366 call check_initialization ("cpm_$scheduler");
367
368 mask = ""b;
369 on any_other call any_other_handler ();
370
371 call scheduler$find_runnable ();
372
373 return;
374 %page;
375
376
377
378
379
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);
387
388 P_user_cl_intermediary = control_point_data.user_cl_intermediary;
389
390 P_code = 0;
391
392 return;
393
394
395
396
397
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);
405
406 control_point_data.user_cl_intermediary = P_user_cl_intermediary;
407
408 P_code = 0;
409
410 return;
411
412
413
414
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
423
424 generate_call:
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:
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:
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);
449
450 mask = ""b;
451 on any_other call any_other_handler ();
452
453
454 if current_cpd_ptr = cpd_ptr
455 then do;
456
457
458
459
460
461
462 call mask_ips_interrupts (mask);
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 ();
471
472 if trace_$transaction_begin (1)
473 then ;
474
475 unspec (userproc_arg_list.header) = ""b;
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
482
483 if trace_$transaction_end (1)
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 ();
489
490 call cu_$set_cl_intermediary (current_control_point_data.cl_intermediary);
491 call restore_privileges ();
492
493 mask = current_control_point_data.ips_mask;
494 call unmask_ips_interrupts (mask);
495 end;
496
497
498 else do;
499
500
501
502
503
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;
510 prior_state = current_control_point_data.state;
511
512 if current_control_point_data.state ^= CPM_READY
513 then do;
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
521
522
523
524
525 call scheduler$run_specific_control_point ();
526
527 if prior_state ^= CPM_READY
528 then do;
529 cpd_ptr = current_cpd_ptr;
530 call update_state (prior_state);
531 end;
532 end;
533 end;
534
535 P_code = 0;
536
537 return;
538 %page;
539
540
541
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);
551
552
553
554
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);
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;
569 on any_other call any_other_handler ();
570
571 if cpm_data_$preferred_control_point ^= cpd_ptr
572 then do;
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;
579
580 return;
581 %page;
582
583
584
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;
592
593 call find_control_point (P_control_point_id);
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;
603 P_code = cpm_et_$preferred_stack_overflow;
604 return;
605 end;
606
607 mask = ""b;
608 on any_other call any_other_handler ();
609
610 if cpm_data_$preferred_control_point ^= cpd_ptr
611 then do;
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;
628
629 return;
630 %page;
631
632
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;
640 on any_other call any_other_handler ();
641
642 if P_pushed_preferred_control_point
643 then do;
644
645 call mask_ips_interrupts (mask);
646
647 P_pushed_preferred_control_point = "0"b;
648
649 if cpm_data_$preferred_control_point_stack.stack_depth > 0
650 then do;
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
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);
679
680 mask = ""b;
681 on any_other call any_other_handler ();
682
683 call update_meters (current_control_point_data.meters, (0));
684
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;
691
692 return;
693
694
695
696
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;
715
716 return;
717 %page;
718
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
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
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;
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;
751 end;
752
753
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
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
772
773
774 mask_ips_interrupts_caller:
775 entry (P_mask);
776
777 call mask_ips_interrupts (P_mask);
778 return;
779
780
781
782
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
796
797
798 unmask_ips_interrupts_caller:
799 entry (P_mask);
800
801 call unmask_ips_interrupts (P_mask);
802 return;
803
804
805
806
807
808 any_other_handler:
809 procedure ();
810
811 call unmask_ips_interrupts_caller (mask);
812
813 call continue_to_signal_ ((0));
814
815 end any_other_handler;
816 %page;
817
818
819
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;
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
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
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
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);
921
922 else if cpd_1.group_id = cpd_2.group_id
923 then return (cpd_1.swapped_switches ^= cpd_2.swapped_switches);
924
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);
929
930 else return ("1"b);
931
932 end different_switches;
933 %page;
934
935
936 scheduler:
937 procedure ();
938 return;
939
940
941
942
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;
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;
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 ();
960 end;
961 end;
962
963 cpd_ptr = cpm_data_$ready_queue.first;
964
965 call switch_control_points ();
966
967 if cpm_data_$gc_control_points
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
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 ();
984
985 if cpm_data_$gc_control_points
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
993
994 switch_control_points:
995 procedure ();
996
997 if current_cpd_ptr = cpd_ptr
998 then return;
999
1000 call mask_ips_interrupts (mask);
1001
1002
1003
1004
1005
1006
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
1016
1017 if different_switches (current_cpd_ptr, cpd_ptr)
1018 then call save_io_switches ();
1019
1020
1021
1022
1023 cpm_data_$previous_control_point = current_cpd_ptr;
1024
1025 if trace_$transaction_begin (1)
1026 then ;
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
1033
1034
1035
1036
1037 if trace_$transaction_end (1)
1038 then ;
1039
1040
1041
1042
1043 if different_switches (current_cpd_ptr, cpm_data_$previous_control_point)
1044 then call restore_io_switches ();
1045
1046
1047
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);
1055
1056 return;
1057
1058 end switch_control_points;
1059 %page;
1060
1061
1062 gc_dead_control_points:
1063 procedure ();
1064
1065 system_area_ptr = get_system_free_area_ ();
1066
1067 call gc_worker (addr (cpm_data_$root_control_point_data));
1068
1069 cpm_data_$gc_control_points = "0"b;
1070
1071 return;
1072
1073
1074
1075
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
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
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
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 ();
1120
1121 local_usage.number_wanted = MAX_NUMBER_OF_METERS;
1122 call hcs_$get_process_usage (addr (local_usage), (0));
1123
1124 call mask_ips_interrupts (mask);
1125
1126 p_n_schedules = p_n_schedules + 1;
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
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
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;
1154 call set_preferred_control_point (cpm_data_$root_control_point_data.id, (0));
1155 end;
1156
1157 if control_point_data.state = CPM_READY
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
1163 then call insert_into_ready_queue ();
1164
1165 else if control_point_data.state = CPM_DESTROYED
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;
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
1183
1184 update_state_caller:
1185 entry (P_cpd_ptr, P_new_state);
1186
1187 mask = ""b;
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
1197
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;
1206
1207 if control_point_data.state = CPM_READY
1208 then do;
1209 call remove_from_ready_queue ();
1210 call insert_into_ready_queue ();
1211 end;
1212
1213
1214
1215
1216 old_preferred_cpd_ptr = cpm_data_$preferred_control_point;
1217
1218 cpm_data_$preferred_control_point = cpd_ptr;
1219
1220 cpd_ptr = old_preferred_cpd_ptr;
1221
1222
1223
1224
1225 control_point_data.preferred = "0"b;
1226
1227 if control_point_data.state = CPM_READY
1228 then do;
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
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 ();
1246 next_cpd_ptr = cpm_data_$ready_queue.first;
1247
1248 if control_point_data.preferred
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;
1256 else prev_cpd_ptr = next_cpd_ptr;
1257 end;
1258
1259 INSERT_INTO_THE_LIST:
1260 if prev_cpd_ptr = null ()
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 ()
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
1278
1279 remove_from_ready_queue:
1280 procedure ();
1281
1282 if control_point_data.prev_ready = null ()
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 ()
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 ();
1291
1292 return;
1293
1294 end remove_from_ready_queue;
1295 %page;
1296
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);
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);
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
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;
1325
1326 control_point_data.priority = create_control_point_info.priority;
1327 control_point_data.preferred = "0"b;
1328
1329 control_point_data.last_frame_ptr = null ();
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,
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;
1346
1347 control_point_data.privileges = ""b;
1348
1349 control_point_data.cl_intermediary = cpm_overseer_$cl_intermediary;
1350
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
1355
1356 control_point_data.meters = 0;
1357
1358
1359
1360
1361 call mask_ips_interrupts_caller (mask);
1362
1363 if trace_$transaction_begin (1)
1364 then ;
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
1383
1384 if parent_control_point_data.first_child = null ()
1385 then do;
1386 parent_control_point_data.first_child = cpd_ptr;
1387 control_point_data.prev_peer = null ();
1388 end;
1389 else do;
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
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
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
1435
1436 return (a_label);
1437
1438 end cv_entry_to_label_;
1439
1440 end create_control_point;
1441 %page;
1442
1443
1444
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
1458
1459 if p_control_point_data.parent ^= null ()
1460 then do;
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);
1464
1465
1466
1467
1468
1469 if p_control_point_data.prev_peer = null ()
1470 then do;
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;
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;
1486
1487
1488
1489
1490 if p_control_point_data.stack_ptr ^= null ()
1491 then do;
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
1498
1499 free p_control_point_data in (system_area);
1500 p_cpd_ptr = null ();
1501
1502 return;
1503
1504 end destroy_control_point;
1505 %page;
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
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),
1533 2 header like stack_frame aligned,
1534 2 arguments,
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,
1543 3 header like arg_list.header,
1544 3 arg_ptrs (3) pointer,
1545 2 callee_arg_list,
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);
1551
1552 sb = control_point_data.stack_ptr;
1553 sp = stack_header.stack_end_ptr;
1554
1555 stack_frame.return_ptr = codeptr (p_caller);
1556 stack_frame.translator_id = TRANSLATOR_ID_ALM;
1557
1558 call_frame.caller_info = p_caller_info;
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
1565
1566 unspec (call_frame.caller_arg_list.header) = ""b;
1567 call_frame.caller_arg_list.header.call_type = Interseg_call_type;
1568 call_frame.caller_arg_list.header.arg_count = 3;
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
1575
1576 unspec (call_frame.callee_arg_list.header) = ""b;
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
1583
1584 control_point_data.last_frame_ptr = sp;
1585
1586 stack_frame.next_sp,
1587 Note
1588
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
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
1613
1614 end cpm_;