



		    act_proc.pl1                    11/11/89  1107.3r w 11/11/89  0804.6      312525



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



/****^  HISTORY COMMENTS:
  1) change(88-05-09,Fawcett), approve(88-05-10,MCR7904),
     audit(88-06-24,Farley), install(88-08-22,MR12.2-1087):
     This change provides a cleanup based on the evolution of process creation.
                                                   END HISTORY COMMENTS */


/* format: style4 */

/* ACT_PROC -	Procedure to create and/or activate a process
   .		This procedure assumes that the calling process has directory privileges,
   .		so that it can create the KST, PDS, and PIT in the new, upgraded process directory.

   Last Modified: (Date and reason)
   08/05/71 by Richard H. Gumpertz to combine pds, pdf
   08/10/72 by Richard G. Bratt to implement "no permanent storage" users
   740726 by PG to add AIM & audit info
   741210 by PG to use privileged initiate on KST, PDS, and PIT.
   750601 by RE Mullen (for priority scheduler) to call set_work_class
   10/13/75 by R. Bratt for prelinking
   760101 by REM for for deadline scheduler
   03/23/76 by S. Webber for new reconfiguration
   02/22/77 by THVV for dsegs with branches
   May 1978 by T. Casey to use active_hardcore_data$pdir_quota as a default value rather than an upper limit on pdir quotas,
   .		giving system and project administrators complete flexibility in using the per-user pdir quota mechanism.
   August 1978 by Greenberg for variable-size DSEG's and KST's.
   May 1979 by Mike Grady for ring 0 stack sharing.
   Modified July 1979 by T. Casey for MR8.0 to add set_pit_tty_info entry point for process preservation across hangups.
   Modified January 1981 by Benson I. Margulies for change of outer module on reconnection.
   Modified February 1983 by E. N. Kittlitz for default kst 256k connection enabling.
   Modified October 1984 by Keith Loepere to use fs_modes.
   Modified 1984-11-11 by E. Swenson for IPC event channel validation;
   act_proc$create initializes apte.ipc_r_offset.
   Modified December 1984 by Keith Loepere to set pds$throttle_segment_state_changes.
   Modified December 1984 by Keith Loepere for pdir_dir_quota.
*/

act_proc: procedure;

/* Variables */

dcl  PRELINKED_DIR char (64);
dcl  abs_ptr ptr;
dcl  bc fixed bin (24);
dcl  evolution fixed bin (17);			/* tracks the creation of a process */
dcl  1 branch_info like create_branch_info aligned;	/* need auto store for this structure  */
dcl  clr_size fixed bin;
dcl  code fixed bin (35);
dcl  ignore_code fixed bin (35);
dcl  cp ptr;
dcl  daemon_sw bit (1) aligned;
dcl  dbr fixed bin (71);
dcl  1 dir_acl (3) aligned,				/* structure for placing 3 ACLs on directories */
       2 userid char (32),
       2 mode bit (36),
       2 status_code fixed bin (35);
dcl  dir_aclp ptr;
dcl  dseg_ptr ptr;
dcl  dseg_size fixed bin (19);
dcl  dstep ptr;
dcl  esw fixed bin;
dcl  hd char (32);
dcl  i fixed bin;
dcl  is_absentee bit (1) aligned;
dcl  kst_ptr ptr;
dcl  kst_size fixed bin (19);
dcl  local_audit_event_flags bit (36) aligned;
dcl  lot_size fixed bin;
dcl  max_authorization bit (72) aligned;
dcl  max_lot fixed bin;
dcl  n fixed bin;
dcl  p ptr;
dcl  p1 ptr;
dcl  p2 ptr;
dcl  pdir_dir_quota fixed bin (17);
dcl  pdir_entry char (15);
dcl  pdir_path char (32);
dcl  pdir_quota fixed bin (17);
dcl  pds_astep ptr;
dcl  pds_ptr ptr;
dcl  pid bit (36) aligned;
dcl  process_authorization bit (72) aligned;
dcl  process_group char (32) aligned;
dcl  rings (3) fixed bin (3);
dcl  savring fixed bin;
dcl  1 seg_acl (3) aligned,				/* structure for placing 3 ACLs on segments */
       2 userid char (32),
       2 mode bit (36),
       2 exmode bit (36),
       2 status_code fixed bin (35);
dcl  seg_aclp ptr;
dcl  seg_rb (3) fixed bin;
dcl  segno fixed bin;
dcl  stop_type bit (1) aligned;
dcl  template_dsegp ptr;
dcl  template_kstp ptr;
dcl  tsdw fixed bin (71);
dcl  work_class fixed bin;

/* Based */

dcl  1 ack_name aligned based,
       2 person char (32),
       2 project char (32),
       2 tag char (1);
dcl  based_dseg (0:n) fixed bin (71) based;
dcl  copy_audit bit (36) aligned based;
dcl  copy_authorization bit (72) aligned based;
dcl  copy_chn_name fixed bin (71) based;
dcl  copy_data (n) fixed bin based;
dcl  copy_dir_name char (32) aligned based;
dcl  copy_dstep bit (18) aligned based;
dcl  copy_event_count fixed bin based;
dcl  copy_group_id char (32) aligned based;
dcl  copy_home_dir char (64) aligned based;
dcl  copy_id bit (36) aligned based;
dcl  copy_prelinked_ring (7) bit (1) unaligned based;
dcl  copy_ptr ptr based;
dcl  copy_ring fixed bin based;
dcl  copy_size (0:7) fixed bin based;
dcl  copy_throttle_seg_state_chg bit (1) aligned based;
dcl  copy_time fixed bin (71) based;
dcl  1 stack aligned based (sb),
       2 header like stack_header,
       2 first_frame fixed bin;

/* External */

dcl  abs_seg$ fixed bin ext;
dcl  active_all_rings_data$default_max_segno fixed bin (17) ext;
dcl  active_all_rings_data$hcscnt fixed bin (18) ext;
dcl  active_all_rings_data$max_segno fixed bin (17) ext;
dcl  active_all_rings_data$stack_base_segno fixed bin (18) ext;
dcl  active_hardcore_data$pdir_dir_quota fixed bin ext;
dcl  active_hardcore_data$pdir_quota fixed bin ext;
dcl  dseg$ fixed bin ext;
dcl  error_table_$ai_restricted fixed bin (35) external static;
dcl  error_table_$apt_full fixed bin (35) external static;
dcl  error_table_$invalid_subsystem fixed bin (35) ext;
dcl  error_table_$smallarg fixed bin (35) external static;
dcl  kst_seg$ fixed bin ext;
dcl  pds$ fixed bin ext;
dcl  pds$access_authorization bit (72) aligned external static;
dcl  1 pds$access_name aligned external,
       2 person char (32),
       2 project char (32),
       2 tag char (1);
dcl  pds$account_id bit (36) aligned external;
dcl  pds$apt_ptr ptr ext;
dcl  pds$audit_flags bit (36) aligned external static;
dcl  pds$clr_stack_size (0:7) fixed bin ext;
dcl  pds$covert_event_count fixed bin ext;
dcl  pds$dstep bit (18) aligned ext;
dcl  pds$first_covert_event_time fixed bin (71) ext;
dcl  pds$highest_ring fixed bin ext;
dcl  pds$home_dir char (168) aligned external;
dcl  pds$initial_procedure ptr ext;
dcl  pds$initial_ring fixed bin ext;
dcl  pds$interrupt_ring fixed bin ext;
dcl  pds$last_sp ptr ext aligned;
dcl  pds$lock_id bit (36) aligned ext;
dcl  pds$lot_stack_size (0:7) fixed bin ext;
dcl  pds$max_access_authorization bit (72) aligned external static;
dcl  pds$max_lot_size (0:7) fixed bin ext;
dcl  pds$prelinked_ring (7) bit (1) unaligned ext;
dcl  pds$process_dir_name char (32) aligned ext;
dcl  pds$process_group_id char (32) aligned ext;
dcl  pds$processid bit (36) aligned ext;
dcl  pds$term_channel fixed bin (71) ext;
dcl  pds$term_proc bit (36) aligned external;
dcl  pds$throttle_segment_state_changes bit (1) aligned ext;
dcl  sst$seg_state_change_limit fixed bin external;
dcl  sys_info$access_class_ceiling bit (72) aligned external static;
dcl  sys_info$default_256K_enable fixed bin ext;
dcl  sys_info$page_size fixed bin ext;
dcl  sys_info$time_of_bootload fixed bin (71) ext;
dcl  tc_data$pdscopyl fixed bin ext;
dcl  tc_data$stat (0:5) fixed bin ext;
dcl  tc_data$timax fixed bin ext;
dcl  template_pds$ fixed bin ext;

/* Entries */

dcl  acc_name_$elements entry (ptr, ptr, fixed bin (35));
dcl  access_audit_$check_general_user entry (bit (36) aligned, bit (36) aligned, bit (72) aligned, bit (36) aligned) returns (bit (1) aligned);
dcl  aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  append$branchx entry (char (*), char (*), fixed bin (5), (3) fixed bin, char (*) aligned, fixed bin, fixed bin, fixed bin (24), fixed bin (35));
dcl  append$create_branch_ entry (char (*), char (*), ptr, fixed bin (35));
dcl  asd_$replace_dall entry (char (*), char (*), ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  asd_$replace_sall entry (char (*), char (*), ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  chname$cfile entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  delentry$dfile entry (char (*), char (*), fixed bin (35));
dcl  del_dir_tree entry (char (*), char (*), fixed bin (35));
dcl  fs_modes entry (ptr, bit (36) aligned, bit (36) aligned, (3) fixed bin (3), fixed bin (35));
dcl  get_ptrs_$given_astep ext entry (ptr) returns (fixed bin (71));
dcl  getuid ext entry returns (bit (36) aligned);
dcl  grab_aste entry (ptr, fixed bin (18), fixed bin (35)) returns (ptr);
dcl  grab_aste$prewithdraw entry (ptr, fixed bin (18), fixed bin (35)) returns (ptr);
dcl  init_proc entry;
dcl  initiate entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35));
dcl  initiate$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  initiate$priv_init entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35));
dcl  level$get ext entry (fixed bin);
dcl  level$set ext entry (fixed bin);
dcl  pxss$empty_t ext entry (ptr);
dcl  pxss$get_entry ext entry (ptr);
dcl  pxss$set_work_class ext entry (bit (36) aligned, fixed bin, fixed bin, fixed bin (35));
dcl  syserr$error_code entry options (variable);
dcl  terminate_$noname ext entry (ptr, fixed bin (35));
dcl  unique_chars_ entry (bit (*)) returns (char (15));

/* constants */

dcl  CREATE init (0) fixed bin static options (constant);
dcl  INFO init (1) fixed bin static options (constant);
dcl  NORMAL_EVOLUTION_TERMINATION init (1) fixed bin static options (constant);
dcl  REW_bit bit (5) static options (constant) init ("1110"b);
dcl  RW_mode fixed bin (5) initial (01010b) static options (constant); /* mode bits for segments we create */
dcl  SMA_bit bit (5) static options (constant) init ("111"b);
dcl  SMA_mode fixed bin (5) initial (01011b) static options (constant); /* mode bits for directories we create */
dcl  dir_rb (3) fixed bin static options (constant) init (7, 7, 7);

/* builtins */

dcl  (addr, baseno, baseptr, binary, bin, bit, clock, divide, fixed, length, max, min, null, ptr, rel, rtrim, size, string, substr, unspec) builtin;

/* Parameters */

dcl  a_code fixed bin (35) parameter;
dcl  ci_ptr ptr parameter;
%page;
create: entry (ci_ptr, a_code);


	evolution = NORMAL_EVOLUTION_TERMINATION;	/* the normal evolution exit */

	esw = CREATE;				/* set entry switch indicating create entry */
	cp = ci_ptr;				/* copy input pointer */
	call level$get (savring);			/* save validation level */
	call level$set (0);				/* and reset to zero */

/* Validate the process authorization & max authorization against the system access_ceiling */

	process_authorization = cp -> create_info.process_authorization;
	max_authorization = cp -> create_info.max_process_authorization;

	if ^aim_check_$greater_or_equal (sys_info$access_class_ceiling, max_authorization)
	then go to return_ai_error;

	if ^aim_check_$greater_or_equal (max_authorization, process_authorization) then do;

return_ai_error:
	     code = error_table_$ai_restricted;		/* auth <= max <= ceiling */
	     go to EVOLUTION_CLEANUP (evolution);
	end;

	call pxss$get_entry (aptep);			/* get an APT entry for the new process */
	if aptep = null then do;			/* if null, no more room */
	     code = error_table_$apt_full;		/* return non-zero code */
	     go to EVOLUTION_CLEANUP (evolution);
	end;

	evolution = evolution + 1;			/* ADD apte removal */

	cp -> create_info.processid.rel_apte = rel (aptep); /* return rest of processid */
	pid = string (cp -> create_info.processid);	/* copy the processid */
	pdir_entry = unique_chars_ ((pid));
	pdir_path = ">process_dir_dir>" || pdir_entry;	/* get path name */

	process_group = cp -> create_info.process_group_id; /* copy process group id */

	stop_type = "1"b;				/* assume this is answering service 7.4 or higher */

/* Create an upgraded process directory */

	pdir_quota = cp -> create_info.record_quota;
	if pdir_quota = 0 then			/* if they blow it with the new pdir quota mechanism */
	     pdir_quota = active_hardcore_data$pdir_quota;/* be reasonable */
	pdir_quota = max (pdir_quota, 20);		/* make sure it's enough to get running */

	pdir_dir_quota = cp -> create_info.dir_quota;
	if pdir_dir_quota = 0 then
	     pdir_dir_quota = active_hardcore_data$pdir_dir_quota;
	pdir_dir_quota = max (pdir_dir_quota, 10);	/* make sure it's enough to get running */

	unspec (branch_info) = "0"b;
	branch_info.version = create_branch_version_2;
	branch_info.mode = substr (SMA_bit, 1, length (branch_info.mode));
	branch_info.rings (1) = dir_rb (1);
	branch_info.rings (2) = dir_rb (2);
	branch_info.rings (3) = dir_rb (3);
	branch_info.userid = pds$process_group_id;
	branch_info.switches.dir_sw = "1"b;
	branch_info.switches.copy_sw = "0"b;
	branch_info.switches.chase_sw = "0"b;		/* don't chase links */
	branch_info.parent_ac_sw = "0"b;		/* Upgrade the dir */
	branch_info.switches.priv_upgrade_sw = "0"b;	/* really move quota from >pdd */
	branch_info.bitcnt = 0;
	branch_info.quota = pdir_quota;
	branch_info.dir_quota = pdir_dir_quota;
	branch_info.access_class = process_authorization;

	call append$create_branch_ (">process_dir_dir", pdir_entry, addr (branch_info), code);
	if code ^= 0 then go to EVOLUTION_CLEANUP (evolution);


	do i = 1 to 3;				/* set up access control lists */
	     seg_acl (i).mode = REW_bit;		/* Default access for process dir segments is REW */
	     seg_acl (i).exmode = "0"b;		/* and no extended mode set */
	     dir_acl (i).mode = SMA_bit;		/* Default access for process dir is SMA */
	end;

	evolution = evolution + 1;			/* increment the evolution to include the process_dir */

	seg_acl (1).userid = process_group;		/* give access to created process first */
	dir_acl (1).userid = process_group;
	seg_acl (2).userid = pds$process_group_id;	/* give access to system control */
	dir_acl (2).userid = pds$process_group_id;
	seg_acl (3).userid = "*.*.*";			/* ... everybody else */
	dir_acl (3).userid = "*.*.*";
	seg_acl (3).mode,				/* give null access to everyone else */
	     dir_acl (3).mode = "0"b;

	seg_aclp = addr (seg_acl (1).userid);		/* get pointer to segment ACL */
	dir_aclp = addr (dir_acl (1).userid);		/* get pointer to directory ACL */

	daemon_sw = "1"b;				/* Don't add "*.SysDaemon.*" to ACLs */
	call asd_$replace_dall (">process_dir_dir", pdir_entry, dir_aclp, 3, daemon_sw, code); /* directory branch acl */
	if code ^= 0 then go to EVOLUTION_CLEANUP (evolution);

	call create_hardcore_seg ("dseg", dseg_ptr);	/* create descriptor segment */
	if dseg_ptr = null then go to EVOLUTION_CLEANUP (evolution);

	evolution = evolution + 1;			/* increment the evolution to show the creation of segments */

	call create_hardcore_seg ("kst", kst_ptr);	/* create known segment table KST */
	if kst_ptr = null then go to EVOLUTION_CLEANUP (evolution);


	call create_hardcore_seg ("pds", pds_ptr);	/* create process data segment (PDS) */
	if pds_ptr = null then go to EVOLUTION_CLEANUP (evolution);

	n = tc_data$pdscopyl;			/* copy the template PDS */
	pds_ptr -> copy_data = addr (template_pds$) -> copy_data;

	if cp -> create_info.version > 4
	then PRELINKED_DIR = cp -> create_info.subsystem;
	else PRELINKED_DIR = "";

	if PRELINKED_DIR ^= "" then do;
	     template_dsegp, template_kstp = null ();	/* init for cleanup */
	     call initiate (PRELINKED_DIR, "template_kst", "", 0, 0, template_kstp, code);
	     if template_kstp = null ()
	     then do;
bad_subsystem:
		code = error_table_$invalid_subsystem;
		go to EVOLUTION_CLEANUP (evolution);
	     end;
	     evolution = evolution + 1;		/* Need to terminate reference to template_kst if abort */
	     if template_kstp -> kst.time_of_bootload ^= sys_info$time_of_bootload | ^template_kstp -> kst.template
	     then go to bad_subsystem;
	     call fs_modes (template_kstp, ("0"b), ("0"b), rings, code);
	     if code ^= 0 | rings (1) ^= 0 then go to bad_subsystem;
	     n = bin (rel (addr (template_kstp -> kst.kst_entry (template_kstp -> kst.highseg + 1))));
	     kst_ptr -> copy_data = template_kstp -> copy_data;
	     ptr (pds_ptr, rel (addr (pds$prelinked_ring))) -> copy_prelinked_ring = kst_ptr -> kst.prelinked_ring;
	     call terminate_$noname (template_kstp, code);
	     if code ^= 0 then go to bad_subsystem;
	     evolution = evolution - 1;		/* decrement because reference to template_kst terminated */
	end;
						/* Compute the sizes and locations of the LOT and CLR */

	lot_size = cp -> create_info.lot_size;
	clr_size = cp -> create_info.cls_size;
	max_lot = cp -> create_info.kst_size;
	if max_lot = 0 then max_lot = active_all_rings_data$default_max_segno + 1;
	max_lot = min (max_lot, active_all_rings_data$max_segno + 1);
	if max_lot <= active_all_rings_data$hcscnt
	then do;
	     code = error_table_$smallarg;
	     call syserr$error_code (LOG, code, "act_proc: KST size specified (^d) less than minimum (^d). Creating process for ^a.", max_lot, active_all_rings_data$hcscnt, cp -> create_info.process_group_id);
	     go to EVOLUTION_CLEANUP (evolution);
	end;

/* Now fill in the per-process variables into the new pds */
	if cp -> create_info.lot_in_stack then do;
	     p = ptr (pds_ptr, rel (addr (pds$lot_stack_size (0))));
	     do i = 0 to 7;
		p -> copy_size (i) = lot_size;
	     end;
	end;

	if cp -> create_info.cls_in_stack then do;
	     p = ptr (pds_ptr, rel (addr (pds$clr_stack_size (0))));
	     do i = 0 to 7;
		p -> copy_size (i) = clr_size;
	     end;
	end;

	p = ptr (pds_ptr, rel (addr (pds$max_lot_size (0))));
	do i = 0 to 7;
	     p -> copy_size (i) = max_lot;
	end;

	p = ptr (pds_ptr, rel (addr (pds$processid)));	/* fill in process id */
	p -> copy_id = pid;

	p = ptr (pds_ptr, rel (addr (pds$lock_id)));
	p -> copy_id = getuid ();			/* Get lock ID */

	p = ptr (pds_ptr, rel (addr (pds$apt_ptr)));	/* fill in APT entry pointer */
	p -> copy_ptr = aptep;

	p = ptr (pds_ptr, rel (addr (pds$account_id)));	/* initialize pds$account id */
	p -> copy_id = pds$account_id;

	p = ptr (pds_ptr, rel (addr (pds$process_dir_name))); /* initialize pds$process_dir_name */
	p -> copy_dir_name = pdir_path;

	p = ptr (pds_ptr, rel (addr (pds$process_group_id))); /* initialize pds$process_group_id */
	p -> copy_group_id = process_group;

	p = ptr (pds_ptr, rel (addr (pds$initial_ring))); /* copy intial ring into pds */
	p -> copy_ring = cp -> create_info.initial_ring;

	p = ptr (pds_ptr, rel (addr (pds$initial_procedure)));
	p -> copy_ptr = addr (init_proc);		/* Set initial procedure for process. */

	p = ptr (pds_ptr, rel (addr (pds$last_sp)));
	sb = baseptr (active_all_rings_data$stack_base_segno);
	p -> copy_ptr = addr (stack.first_frame);	/* Setup first time stack ptr */

	p = ptr (pds_ptr, rel (addr (pds$interrupt_ring))); /* copy interrupt ring into pds */
	p -> copy_ring = cp -> create_info.initial_ring;	/* use initial ring for users */

	p = ptr (pds_ptr, rel (addr (pds$highest_ring))); /* copy highest ring into pds */
	p -> copy_ring = cp -> create_info.highest_ring;

	p = ptr (pds_ptr, rel (addr (pds$access_name)));	/* fill in 3 part access name in pds */
	call acc_name_$elements (addr (process_group), p, code);
	if code ^= 0 then go to EVOLUTION_CLEANUP (evolution);
	if p -> ack_name.tag = "m" then is_absentee = "1"b;
	else is_absentee = "0"b;

	p1 = ptr (pds_ptr, rel (addr (pds$term_proc)));	/* copy terminate process id into pds */
	p1 -> copy_id = cp -> create_info.term_processid;

	p1 = ptr (pds_ptr, rel (addr (pds$term_channel)));/* copy terminate channel name into pds */
	p1 -> copy_chn_name = cp -> create_info.term_channel;

	p = ptr (pds_ptr, rel (addr (pds$access_authorization)));
	p -> copy_authorization = process_authorization;

	p = ptr (pds_ptr, rel (addr (pds$max_access_authorization)));
	p -> copy_authorization = max_authorization;

	p = ptr (pds_ptr, rel (addr (pds$audit_flags)));
	p -> copy_audit = cp -> create_info.audit;

	seg_rb (1) = 0;				/* create pit with rb of (0, 5, 5) */
	seg_rb (2), seg_rb (3) = cp -> create_info.highest_ring;
	pit_ptr = null;
	call append$branchx (pdir_path, "pit", (RW_mode), seg_rb, process_group, 0, 0, 0, code);
	if code ^= 0 then go to EVOLUTION_CLEANUP (evolution);

	call asd_$replace_sall (pdir_path, "pit", seg_aclp, 3, daemon_sw, code);
	if code ^= 0 then go to EVOLUTION_CLEANUP (evolution);

	call initiate$priv_init (pdir_path, "pit", "", 0, 0, pit_ptr, code);
	if pit_ptr = null then go to EVOLUTION_CLEANUP (evolution);
	n = cp -> create_info.words_of_pit;		/* copy the pit template */
	pit_ptr -> copy_data = cp -> create_info.pit_ptr -> copy_data;
	p2 = ptr (pds_ptr, rel (addr (pds$home_dir)));
	if substr (ptr (pit_ptr, cp -> create_info.homedir) -> copy_home_dir, 1, 5) ^= "[pd]>"
	then p2 -> copy_home_dir = ptr (pit_ptr, cp -> create_info.homedir) -> copy_home_dir;
	else do;
	     hd = substr (ptr (pit_ptr, cp -> create_info.homedir) -> copy_home_dir, 6, 32);
	     call append$branchx (pdir_path, hd, (SMA_mode), dir_rb, process_group, 1, 0, 0, code);
	     if code ^= 0 then go to EVOLUTION_CLEANUP (evolution);
	     call asd_$replace_dall (pdir_path, hd, dir_aclp, 3, daemon_sw, code); /* directory acl */
	     if code ^= 0 then go to EVOLUTION_CLEANUP (evolution);
						/* fill in true home directory in PIT */
	     p2 -> copy_home_dir = rtrim (pdir_path) || ">" || rtrim (hd);
	     ptr (pit_ptr, cp -> create_info.homedir) -> copy_home_dir = p2 -> copy_home_dir;
	end;

	call terminate_$noname (pit_ptr, code);		/* terminate copy */
	if code ^= 0 then go to EVOLUTION_CLEANUP (evolution);

	aptep -> apte.processid = pid;		/* set up process id in KPT entry */

	aptep -> apte.access_authorization = cp -> create_info.process_authorization;
	work_class = cp -> create_info.work_class;	/* Yes */
	call pxss$set_work_class (pid, work_class, 0, code); /* Set it */
	if code ^= 0 then go to EVOLUTION_CLEANUP (evolution); /* Unable to set it */

/*	go to common;				/* go to activate this process */
/**/
/* activate: entry(aaptep, a_code);			/* entry to activate an inactive process */

/* dcl  aaptep ptr;					/* pointer to KPT (APT) entry */
/* dcl  ACTIVATE init (2) fixed bin static options (constant); */

/*	esw = ACTIVATE;				/* set entry switch for activate entry */
/*        evolution = NORMAL_EVOLUTION_TERMINATION */
/*	stop_type = "1"b;				/* I guess. */
/*	aptep = aaptep;				/* pick up pointer to KPT entry */
/*	pid = aptep -> apte.processid;		/* pick up process id */
/*	call level$get(savring);			/* save validation level */
/*	call level$set(0);				/* reset validation level to zero */
/*	pdir_entry = unique_chars_((pid));		/* compute process directory entry name */
/*	pdir_path = ">process_dir_dir>" || pdir_entry; */
/*	call initiate$priv_init (pdir_path, "dseg", "", 0, 0, dseg_ptr, code); /* initiate dseg */
/*	if dseg_ptr = null then go to EVOLUTION_CLEANUP (evolution); */
/*	call initiate$priv_init (pdir_path, "kst", "", 0, 0, kst_ptr, code); /* initiate KST */
/*	if kst_ptr = null then go to EVOLUTION_CLEANUP (evolution); */
/*	call initiate$priv_init (pdir_path, "pds", "", 0, 0, pds_ptr, code); /* initiate PDS */
/*	if pds_ptr = null then go to  EVOLUTION_CLEANUP (evolution); */
/* COMMENTED OUT BECAUSE IT'S NOT PRESENTLY USED. */
/* CAUTION: if the activate entry point is ever revieved then PRELINKED_DIR */
/*          must be stored in the guys pds.  Some where the segments need to */
/*	  be terminated if the activation is aborted. This should be in  */
/*	  EVOLUTION_CLEANUP condition by the value of esw */

common:	abs_ptr = addr (abs_seg$);			/* create process code joins activate code here */
	n = active_all_rings_data$hcscnt - 1;		/* Set up descriptor segment for new process. */
						/* copy all SDW's up to first stacks (ring 0) SDW */
	dseg_ptr -> based_dseg = addr (dseg$) -> based_dseg;
	dseg_size = size (sdw) * max_lot;
	call set_ehs (dseg_ptr, "1"b, divide (dseg_size + sys_info$page_size - 1, sys_info$page_size, 17, 0));
	segno = bin (baseno (addr (dseg$)), 18);	/* Get segno of dseg */
	dseg_ptr -> sdwa (segno).add = addr (tsdw) -> sdw.add; /* Fill in page table addr */
	dseg_ptr -> sdwa (segno).bound = bit (fixed (divide (dseg_size + 15, 16, 17, 0) - 1, 14), 14);
	dseg_ptr -> sdwa (segno).entry_bound = bit (divide (active_all_rings_data$stack_base_segno, 8, 14, 0), 14);
	dstep = astep;				/* Save ptr to ASTE for dseg */
	unspec (dbr) = string (dseg_ptr -> sdwa (segno));

	if PRELINKED_DIR ^= "" then do;
	     call initiate$initiate_count (PRELINKED_DIR, "template_dseg", "", bc, 0, template_dsegp, code);
	     if template_dsegp = null () then go to bad_subsystem;
	     evolution = evolution + 1;		/* Need to terminate reference to template_dseg if abort */
	     call fs_modes (template_dsegp, ("0"b), ("0"b), rings, code);
	     if code ^= 0 then go to bad_subsystem;
	     if rings (1) ^= 0 then go to bad_subsystem;
	     n = divide (bc, 72, 17, 0) - active_all_rings_data$hcscnt;
	     if n <= 0 then go to bad_subsystem;
	     addr (dseg_ptr -> sdwa (active_all_rings_data$hcscnt)) -> based_dseg =
		addr (template_dsegp -> sdwa (active_all_rings_data$hcscnt)) -> based_dseg;
	     call terminate_$noname (template_dsegp, code);
	     evolution = evolution - 1;		/* decrement because reference to template_dseg terminated */
	end;

	p = ptr (pds_ptr, rel (addr (pds$dstep)));	/* save pointer to hardcore DST entry */
	p -> copy_dstep = rel (dstep);
	kst_size = size (kst) + size (kste) * (max_lot - active_all_rings_data$hcscnt + 1);
	if kst_ptr -> kst.highseg = 0 then kst_ptr -> kst.highseg = max_lot - 1;
	kst_ptr -> kst.allow_256K_connect = sys_info$default_256K_enable ^= 0;
						/* Init for non pre-linked process */
	call set_ehs (kst_ptr, "0"b, divide (kst_size + sys_info$page_size - 1, sys_info$page_size, 17, 0));
	segno = bin (baseno (addr (kst_seg$)), 18);
	dseg_ptr -> based_dseg (segno) = tsdw;

	call set_ehs (pds_ptr, "1"b, 4);		/* Force PDS active and prewithdraw */
	segno = bin (baseno (addr (pds$)), 18);
	dseg_ptr -> based_dseg (segno) = tsdw;
	pds_astep = astep;

	aptep -> apte.timax = tc_data$timax;		/* initialize to default timax */
	aptep -> apte.flags.state = bit (bin (4, 18), 18);/* set execution state to blocked */
	tc_data$stat (4) = tc_data$stat (4) + 1;	/* up count of blocked processes */
	aptep -> apte.asteps.pds = rel (pds_astep);	/* save ptr to PDS-AST entry */
	aptep -> apte.asteps.dseg = rel (dstep);	/* save ptr to hardcore DST entry */
	aptep -> apte.dbr = dbr;			/* save descriptor segment base register value */
	aptep -> apte.flags2.batch = is_absentee;	/* DIGS wants to know .. */
	aptep -> apte.lock_id = ptr (pds_ptr, rel (addr (pds$lock_id))) -> copy_id;
						/* Place in pds as well */
	aptep -> apte.ws_size = 0;			/* assume no pages to start */
	aptep -> apte.term_processid = ptr (pds_ptr, rel (addr (pds$term_proc))) -> copy_id;
	aptep -> apte.term_channel = ptr (pds_ptr, rel (addr (pds$term_channel))) -> copy_chn_name;
	aptep -> apte.deadline,			/* set deadline here */
	     aptep -> apte.state_change_time = clock ();	/* Initialize it */

	local_audit_event_flags = "0"b;		/* set throttle_segment_state_changes */
	addr (local_audit_event_flags) -> audit_event_flags.grant = "1"b;
	addr (local_audit_event_flags) -> audit_event_flags.cc_10_100 = "1"b;
	ptr (pds_ptr, rel (addr (pds$throttle_segment_state_changes))) -> copy_throttle_seg_state_chg =
	     access_audit_$check_general_user (local_audit_event_flags, "0"b, process_authorization, cp -> create_info.audit);

	ptr (pds_ptr, rel (addr (pds$covert_event_count))) -> copy_event_count = -sst$seg_state_change_limit; /* page_fault counts up to 0 */
	ptr (pds_ptr, rel (addr (pds$first_covert_event_time))) -> copy_time = clock ();

/**** Here we set up apte.ipc_r_offset.  This is an 18-bit unsigned
      integer used by IPC to validate event channel names in conjunction
      with apte.ipc_r_factor.  This latter number is determined later,
      when the process first runs, to provide an indeterminate delay between
      the creation of these values.  The delay is necessary to make it
      difficult to guess the value of apte.ipc_r_factor given the value
      of apte.ipc_r_offset. */

	aptep -> apte.ipc_r_offset =
	     binary (substr (bit (binary (clock (), 54), 54), 37, 18), 18);

/**** Set the value of apte.ipc_r_factor to zero for debugging purposes
      so that we can determine whether it is getting set or not later. */

	aptep -> apte.ipc_r_factor = 0;

	call terminate_$noname (dseg_ptr, code);	/* Terminate dseg */
	if code ^= 0 then go to EVOLUTION_CLEANUP (evolution);
	call terminate_$noname (kst_ptr, code);		/* terminate KST */
	if code ^= 0 then go to EVOLUTION_CLEANUP (evolution);
	call terminate_$noname (pds_ptr, code);		/* terminate PDS */
	if code ^= 0 then go to EVOLUTION_CLEANUP (evolution);

	if esw = CREATE then do;			/* some special stuff left to do if create entry */

	     if cp -> create_info.timax > 0 then aptep -> apte.timax = cp -> create_info.timax;
	     if cp -> create_info.user_processid ^= " " then do; /* additional name for process directory */
		call chname$cfile (">process_dir_dir", pdir_entry, "", (cp -> create_info.user_processid), code);
		if code ^= 0 then go to EVOLUTION_CLEANUP (evolution);
	     end;

	end;

	code = 0;

	go to EVOLUTION_CLEANUP (NORMAL_EVOLUTION_TERMINATION); /* go set level and return */


EVOLUTION_CLEANUP (5):
	if esw = CREATE then do;
	     if template_kstp ^= null ()
	     then call terminate_$noname (template_kstp, ignore_code);
	     if template_dsegp ^= null ()
	     then call terminate_$noname (template_dsegp, ignore_code);
	end;

EVOLUTION_CLEANUP (4):				/* delete any segments that have been created */
	if esw = CREATE then
	     call del_dir_tree (">process_dir_dir", pdir_entry, ignore_code);

EVOLUTION_CLEANUP (3):				/* delete the process dir */
	if esw = CREATE then
	     call delentry$dfile (">process_dir_dir", pdir_entry, ignore_code);

EVOLUTION_CLEANUP (2):				/* Give back the APTE */
	if esw = CREATE then
	     call pxss$empty_t (aptep);

EVOLUTION_CLEANUP (1):				/* restore validation level */
	call level$set (savring);
						/* tell caller what went wrong if any thing did. */
	a_code = code;
	return;

set_pit_tty_info: entry (a_pid, a_pitp, a_code);

dcl  a_pid bit (36) aligned parameter;
dcl  a_pitp ptr parameter;

dcl  pitp ptr;

	esw = INFO;

/* Copy args */
	pid = a_pid;
	pitp = a_pitp;
	code = 0;
						/* Bookkeeping */

	call level$get (savring);			/* save current validation level and set it to zero */
	call level$set (0);
	evolution = NORMAL_EVOLUTION_TERMINATION;
	pdir_entry = unique_chars_ ((pid));		/* compute entry name of user's pdir */
	pdir_path = ">process_dir_dir>" || pdir_entry;	/* get full pathname of pdir */
	pit_ptr = null;
	call initiate$priv_init (pdir_path, "pit", "", 0, 0, pit_ptr, code); /* initiate exiting pit */
	if pit_ptr = null then go to EVOLUTION_CLEANUP (evolution);

/* Copy new tty info from template pit into user's pit */

	pit_ptr -> pit.tty = pitp -> pit.tty;
	pit_ptr -> pit.old_tty = pitp -> pit.old_tty;
	pit_ptr -> pit.terminal_access_class = pitp -> pit.terminal_access_class;
	pit_ptr -> pit.line_type = pitp -> pit.line_type;
	pit_ptr -> pit.term_type_name = pitp -> pit.term_type_name;
	pit_ptr -> pit.service_type = pitp -> pit.service_type;
	pit_ptr -> pit.charge_type = pitp -> pit.charge_type;
	pit_ptr -> pit.tty_answerback = pitp -> pit.tty_answerback;
	pit_ptr -> pit.tty_type = pitp -> pit.tty_type;
	pit_ptr -> pit.outer_module = pitp -> pit.outer_module;

/* Clean up and return */

	call terminate_$noname (pit_ptr, code);
	go to EVOLUTION_CLEANUP (evolution);		/* go set level and return */

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */



create_hardcore_seg: procedure (seg_name, seg_ptr);	/* internal procedure to create hardcore segments */

dcl  seg_name char (*) parameter;			/* segment branch name */
dcl  seg_ptr ptr parameter;				/* pointer to segment (returned) */

	seg_rb (1), seg_rb (2), seg_rb (3) = 0;		/* ring brackets of 0-0-0 on pds and kst */
	seg_ptr = null;
	call append$branchx (pdir_path, seg_name, (RW_mode), seg_rb, process_group, 0, 0, 0, code); /* create branch */
	if code ^= 0 then return;

	call asd_$replace_sall (pdir_path, seg_name, seg_aclp, 3, daemon_sw, code);
	if code ^= 0 then return;

	call initiate$priv_init (pdir_path, seg_name, "", 0, 0, seg_ptr, code); /* initiate created segment */

     end create_hardcore_seg;

set_ehs: proc (segptr, prw, size1);

dcl  prw bit (1) aligned parameter;
dcl  segptr ptr parameter;
dcl  size1 fixed bin parameter;

dcl  size2 fixed bin (18);

	size2 = 1024 * size1;
	if prw then astep = grab_aste$prewithdraw (segptr, size2, code);
	else astep = grab_aste (segptr, size2, code);	/* force activate the entry */
	if code ^= 0 then call syserr$error_code (1, code, "act_proc: from grab_aste");
	tsdw = get_ptrs_$given_astep (astep);
	addr (tsdw) -> sdw.cache = "1"b;		/* KST and PDS are non-shared */
	return;

     end set_ehs;

/* format: off */
%page; %include access_audit_eventflags;
%page; %include apte;
%page; %include aste;
%page; %include create_branch_info;
%page; %include create_info;
%page; %include kst;
%page; %include pit;
%page; %include sdw;
%page; %include stack_header;
%page; %include syserr_constants;
%page; %include user_attributes;
%page;
/* BEGIN MESSAGE DOCUMENTATION
   Message:
   act_proc: from grab_aste ERRORMESSAGE

   S: $crash

   T: $run

   M: In attempting to create a process, the system could not force the
   PDS or descriptor segment of that process to be activated and held active.
   ERRORMESSAGE is an error_table_ message.
   $err

   A: $recover


   Message:
   act_proc: KST size specified (SIZE) less than minimum (MIN_SIZE).
   Creating process for GROUPID.

   S: $log

   T: $run

   M: The project administrator (or system administrator) for user GROUPID
   set the kst_size parameter in the PDT to SIZE, which is less than
   the valid minimum MIN_SIZE. The process is not created. Note that
   a process with MINIMUM KST size will probably not be of any use. The
   minimum useful KST size is on the order of MINIMUM + 50.

   A: Change the PMF/PDT.

   END MESSAGE DOCUMENTATION */
/* format: on */

     end act_proc;




		    check_trailer.alm               11/11/89  1107.3r w 11/11/89  0804.2       15435



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

"
"	check_trailer
"
"	This program loops through the entire trailer segment searching
"	for any trailers which belong to a process which has been (is being)
"	destroyed.  It is a debugging temporary program only.
"
" Modified 04/16/81, W. Olin Sibert, to get count of trailers from sst$n_trailers
"

	name	check_trailer
	entry	check_trailer

check_trailer:

"
"	Call is:
"
"	error = check_trailer(rel_dstep)
"
"	dcl error bit (1) aligned, rel_dstep dixed bin (18)
"
	lda	pr0|2,*		pick up the pointer to the DST entry
	stz	pr0|4,*		zero out return error code

	ldq	sst$n_trailers	get count of trailers in system
	qls	1		multiply by two (size of a trailer)
	eax0	0,ql		and move to X0

	ldq	-1,du		use mask for right half of word 1 of trailer entry
	epp2	str_seg$+0	get pointer to trailer segment itself

loop:	eax0	-2,x0		go to next trailer
	tmi	ok		if haven't found bad one by now we're OK
	cmk	pr2|1,x0		compare a with rel(dstep) in trailer
	tze	trouble		the same, trouble. return "1"b
	tra	loop

ok:	short_return

trouble:	lda	=o400000,du	return "1"b if error
	sta	pr0|4,*
	short_return

	end




		    copy_stack_0.pl1                11/11/89  1107.3r w 11/11/89  0805.1       28530



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


copy_stack_0:
	proc (processid, to_ptr, code);
	
/*     Copies the stack_0 assigned to a specified process

       This routine examines stack_0_data for an active stack_0
       assigned to the specified apte.  If found, it is copied
       to the specified location using initializer_abs_seg;
       otherwise, an error code is returned.

       Written March 1981 by J. Bongiovanni							*/
	
	
/* Parameter */

	dcl processid bit (36) aligned;		/* process id which owns stack		*/
	dcl to_ptr ptr;				/* where to copy stack_0			*/
	dcl code fixed bin (35);			/* error code				*/
	
/* Automatic */

	dcl paptep bit (18);
	dcl sdte_found bit (1);
	dcl sdte_inx fixed bin;
	dcl stack_ptr ptr;
	dcl stack_sdw bit (72) aligned;
	dcl stack_sdw_ptr ptr;
	dcl stack_size fixed bin (19);
	
/* Based */

	dcl stack_copy (stack_size) fixed bin (35) aligned based;
	
/* The following include files are referenced at the end of the program:

	sdw
          stack_0_data
*/
	
/* External */

	dcl initializer_abs_seg$ external;
	dcl error_table_$bad_arg fixed bin (35) external;
	dcl error_table_$stack_not_active fixed bin (35) external;
	dcl sst$ external;
	
/* Entry */

	dcl get_ptrs_$given_astep entry (ptr) returns (bit (72) aligned);
	dcl privileged_mode_ut$swap_sdw entry (ptr, ptr);
	dcl sdw_util_$get_size entry (pointer, fixed bin (19));
	
	%page;
/* Check sdt for a stack belonging to this processid						*/
	
	code = 0;
	sdtp = addr (stack_0_data$);
	paptep = substr (processid, 1, 18);		/* apte offset				*/
	if paptep="0"b then do;			/* null offset - invalid			*/
	     code = error_table_$bad_arg;
	     return;
	end;
	
	     
	
	sdte_found = "0"b;
	do sdte_inx = 1 repeat sdte_inx + 1
	     while (sdte_inx<=sdt.num_stacks&^sdte_found);
	     if stacks (sdte_inx).aptep=paptep then sdte_found = "1"b;
	end;
	
	if ^sdte_found then do;
	     code = error_table_$stack_not_active;
	     return;
	end;
	
	sdtep = addr (sdt.stacks (sdte_inx-1));
	stack_ptr = addr (initializer_abs_seg$);
	stack_sdw_ptr = addr (stack_sdw);
	stack_sdw = get_ptrs_$given_astep (ptr (addr (sst$), sdte.astep));	/* build sdw for stack	*/
	call sdw_util_$get_size (addr (stack_sdw), stack_size);
	
	call privileged_mode_ut$swap_sdw (stack_ptr, stack_sdw_ptr);	/* initializer_abs_seg is now stack	*/
	
	to_ptr -> stack_copy = stack_ptr -> stack_copy;
	
	stack_sdw = "0"b;
	call privileged_mode_ut$swap_sdw (stack_ptr, stack_sdw_ptr);
	
	return;
	
	%page;
	%include stack_0_data;
	
end copy_stack_0;

	
	
	
	



		    create_hproc.pl1                11/11/89  1107.3r w 11/11/89  0805.2      102708



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

/* format: style4 */

create_hproc: proc (access_id, loaded, aptep, initial_procedure) returns (fixed bin (35));

/* Created by Webber for 29-0 (= MR5.0) */
/* Modified by VanVleck, Greenberg for in-hierarchy and hardcore-seg per-proc segments 4/77 */
/* Modified by Mike Grady for stack 0 sharing. May 1979 */
/* Modified by J. Bongiovanni to create a stack for non-early hprocs. December 1982 */
/* Modified 1984-11-16 by E. Swenson for IPC event channel validation.  The
   values of R-Offset and R-Factor are initialized here for hprocs. */
/* Modified 1984-11-20 by Keith Loepere to rename terminate to terminate_. */
/* Modified 1984-12-11, BIM: give *.*.* RW In ring zero to segments.
   this permits ring_zero_peek_ and allows this to work outside
   of the Initializer. */

/* Parameters */

dcl  access_id char (*) aligned;
dcl  loaded bit (1) aligned;
dcl  initial_procedure ptr;

dcl  adsp ptr;
dcl  apdsp ptr;
dcl  astkp ptr;

/* Automatic */

dcl  save_level uns fixed bin (3);
dcl  highseg fixed bin (18);
dcl  dseg_no fixed bin (18);
dcl  dsp ptr;
dcl  pds_ptr ptr;
dcl  stk_ptr ptr;
dcl  stk_astep ptr;
dcl  tcode fixed bin (35);
dcl  dseg_ptr ptr;
dcl  1 pds_sdw aligned like sdw;
dcl  1 dbr aligned like sdw;
dcl  1 stk_sdw aligned like sdw;
dcl  dstep ptr;
dcl  astep ptr;
dcl  proc_id bit (36) aligned;
dcl  lock_id bit (36) aligned;
dcl  pds_no fixed bin;
dcl  append_entry bit (1);

/* External */

dcl  active_all_rings_data$hcscnt fixed bin (18) ext;
dcl  active_all_rings_data$stack_base_segno fixed bin (18) ext;
dcl  (dseg$, slt$) external;
dcl  error_table_$namedup fixed bin (35) external;
dcl  pds$apt_ptr ptr ext;
dcl  pds$stack_0_sdwp ptr ext;
dcl  pds$stack_0_ptr ptr ext;
dcl  pds$stacks (0:7) ptr ext;
dcl  pds$last_sp ptr ext;
dcl  pds$initial_procedure ptr ext;
dcl  pds$processid bit (36) aligned ext;
dcl  pds$lock_id bit (36) aligned ext;
dcl  pds$dstep bit (18) aligned ext;
dcl  pds$process_group_id char (32) aligned ext;
dcl  template_pds$ ext;
dcl  tc_data$pdscopyl fixed bin ext;

/* Based */

dcl  copy_pds (tc_data$pdscopyl) fixed bin based;
dcl  copy_id bit (36) aligned based;
dcl  copy_ptr ptr based;
dcl  copy_group_id char (32) aligned based;
dcl  copy_dstep bit (18) aligned based;
dcl  1 based_dseg (0:highseg) aligned like sdw based;
dcl  1 stack aligned based (sb),
       2 header like stack_header,
       2 first_frame fixed bin;

/* Constant */

dcl  seg_rb (3) fixed bin init (0, 0, 0) static options (constant);
dcl  dseg_size fixed bin static options (constant) init (3 * 1024);
dcl  PDS_SIZE fixed bin internal static options (constant) init (4096);
dcl  STACK_SIZE fixed bin internal static options (constant) init (16384);

/* Entries */

dcl  unique_chars_ entry (bit (*) aligned) returns (char (15));
dcl  append$branchx entry (char (*), char (*), fixed bin (5), (3) fixed bin, char (*) aligned,
	fixed bin, fixed bin, fixed bin, fixed bin (35));
dcl  (level$get, level$set) entry (uns fixed bin (3));
dcl  grab_aste$prewithdraw entry (ptr, fixed bin, fixed bin (35)) returns (ptr);
dcl  get_ptrs_$given_astep entry (ptr) returns (1 aligned like sdw);
dcl  get_ptrs_$given_segno entry (fixed bin (18)) returns (ptr);
dcl  initiate$priv_init entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35));
dcl  terminate_$noname ext entry (ptr, fixed bin (35));
dcl  truncate$trseg entry (ptr, fixed bin (19), fixed bin (35));
dcl  pxss$get_entry entry (ptr);
dcl  getuid entry returns (bit (36) aligned);
dcl  pc_wired$wire_wait entry (ptr, fixed bin, fixed bin);

/* Builtins */

dcl  (addr, baseno, baseptr, bin, bit, divide, null, ptr, rel, size, unspec) builtin;

dcl  cleanup condition;

/**/
/* First get a segment to be used as the PDS */

	append_entry = "1"b;
	call pxss$get_entry (aptep);
	if aptep = null then return (1);
	proc_id = rel (aptep) || "666666"b3;

	call level$get (save_level);
	on cleanup call level$set (save_level);
	call level$set (0);

	call get_unique_segment ("pds", pds_ptr, astep, PDS_SIZE, tcode);
	if tcode ^= 0 then do;
RETURN_ERROR:
	     call level$set (save_level);
	     return (tcode);
	end;

/* Now get a descriptor segment */

	call get_unique_segment ("dseg", dseg_ptr, dstep, dseg_size, tcode);
	if tcode ^= 0 then goto RETURN_ERROR;

/* Now get a stack segment */

	call get_unique_segment ("stack", stk_ptr, stk_astep, STACK_SIZE, tcode);
	if tcode ^= 0 then goto RETURN_ERROR;

	highseg = active_all_rings_data$hcscnt - 1;
	call level$set (save_level);
	revert cleanup;

/* Develop the DBR from the dstep. */

join:
	dbr = get_ptrs_$given_astep (dstep);
	dsp = addr (dseg$);
	dseg_no = bin (baseno (dsp), 18);

	dseg_ptr -> based_dseg = dsp -> based_dseg;
	unspec (dseg_ptr -> sdwa (dseg_no)) = unspec (dbr);

/* Fill in the stack base segno in the DBR so BOS will dump it. */

	if append_entry then
	     dbr.entry_bound = bit (divide (active_all_rings_data$stack_base_segno, 8, 14, 0), 14);

/* Now get an APT entry and fill it in */

	apte.hproc = "1"b;
	apte.state = bit (bin (4, 18), 18);		/* initial state is blocked */
	apte.timax = 4000000;
	apte.wct_index = pds$apt_ptr -> apte.wct_index;	/* use parent's water closet */
	apte.processid = proc_id;
	lock_id = getuid ();
	apte.lock_id = lock_id;
	apte.dseg = rel (dstep);
	apte.pds = rel (astep);
	unspec (apte.dbr) = unspec (dbr);

/**** Here we set up apte.ipc_r_offset for the hardcore process.  This
      is an 18-bit unsigned integer used by IPC to validate event channel
      names in conjunction with apte.ipc_r_factor.  This latter number
      is determined later, in init_proc.  This is done on order to provide
      an undeterministic delay between the initialization of these two
      numbers in order to make it difficult to guess one given the other. */

	apte.ipc_r_offset = binary (substr (bit (binary (clock (), 54), 54), 37, 18), 18);

/**** We defer the setting of R-Factor until after we take a few pages
      faults in order to make guessing R-Factor given R-Offset more
      difficult. */

/* Now initialize the PDS and fill in its SDW into the DSEG */

	pds_no = bin (baseno (addr (pds$processid)), 18);
	pds_sdw = get_ptrs_$given_astep (astep);
	pds_sdw.cache = "1"b;
	dseg_ptr -> based_dseg (pds_no) = pds_sdw;

	pds_ptr -> copy_pds = addr (template_pds$) -> copy_pds;

	ptr (pds_ptr, rel (addr (pds$processid))) -> copy_id = proc_id;
	ptr (pds_ptr, rel (addr (pds$lock_id))) -> copy_id = lock_id;
	ptr (pds_ptr, rel (addr (pds$apt_ptr))) -> copy_ptr = aptep;
	ptr (pds_ptr, rel (addr (pds$process_group_id))) -> copy_group_id = access_id;
	ptr (pds_ptr, rel (addr (pds$dstep))) -> copy_dstep = rel (dstep);
	ptr (pds_ptr, rel (addr (pds$initial_procedure))) -> copy_ptr = initial_procedure;

	sdwp = addr (dseg$);
	if append_entry then do;			/* fill in pds stack info with correct stuff */
	     stk_sdw = get_ptrs_$given_astep (stk_astep);
	     unspec (dseg_ptr -> sdwa (active_all_rings_data$stack_base_segno)) =
		unspec (stk_sdw);
	     ptr (pds_ptr, rel (addr (pds$stack_0_sdwp))) -> copy_ptr =
		addr (sdwa (active_all_rings_data$stack_base_segno));
	     ptr (pds_ptr, rel (addr (pds$stack_0_ptr))) -> copy_ptr,
		ptr (pds_ptr, rel (addr (pds$stacks (0)))) -> copy_ptr,
		sb = ptr (baseptr (active_all_rings_data$stack_base_segno), 0);
	     stk_ptr -> stack_header_overlay = pds$stack_0_ptr -> stack_header_overlay;
	     stk_ptr -> stack_header.stack_begin_ptr,
		stk_ptr -> stack_header.stack_end_ptr = ptr (sb, rel (addr (stack.first_frame)));
	end;
	else do;					/* or for early hprocs */
	     ptr (pds_ptr, rel (addr (pds$stack_0_sdwp))) -> copy_ptr =
		addr (sdwa (bin (baseno (stk_ptr), 18)));
	     ptr (pds_ptr, rel (addr (pds$stack_0_ptr))) -> copy_ptr,
		ptr (pds_ptr, rel (addr (pds$stacks (0)))) -> copy_ptr,
		sb = ptr (stk_ptr, 0);
	end;

	ptr (pds_ptr, rel (addr (pds$last_sp))) -> copy_ptr =
	     addr (stack.first_frame);

/* Now load the process if it must be loaded */

	if loaded then do;				/* the process is always to be loaded */
	     apte.loaded = "1"b;
	     apte.always_loaded = "1"b;
	     call pc_wired$wire_wait (astep, 0, 1);	/* wire first page of PDS */
	     call pc_wired$wire_wait (dstep, 0, 1);	/* wire first page of DSEG */
	end;

	if append_entry then do;
	     call terminate_$noname (pds_ptr, (0));
	     call terminate_$noname (dseg_ptr, (0));
	     call terminate_$noname (stk_ptr, (0));
	end;

/**** Now, after taking some page faults, we set R-Factor.  The clock
      value should be unpredictably more advanced. */

	apte.ipc_r_factor =
	     binary (substr (bit (binary (clock (), 54), 54), 19, 36), 35);

	return (0);

/**/
early_hproc: entry (access_id, loaded, aptep, initial_procedure, adsp, apdsp, astkp) returns (fixed bin (35));

/* This entry is called during initialization, when segments cannot be created via append. Pointers
   to two hardcore segments, adsp and apdsp, are supplied to specify segments to be used as the DSEG and PDS
   of the new process.  These segments should be hardcore if this process is never to be deleted,
   or deciduous if they are later to be deleted. */


	append_entry = "0"b;
	dseg_ptr = adsp;				/* Copy args for common code. */
	pds_ptr = apdsp;
	stk_ptr = astkp;

	astep = get_ptrs_$given_segno (bin (baseno (pds_ptr), 18)); /* Get dseg-seg ptr */
	dstep = get_ptrs_$given_segno (bin (baseno (dseg_ptr), 18)); /* Ditto the pds */
	call pxss$get_entry (aptep);
	if aptep = null then return (1);
	proc_id = rel (aptep) || "666666"b3;		/* Fabricate process ID */
	sltp = addr (slt$);
	highseg = slt.last_sup_seg;
	go to join;				/* Do all the rest */

%page;
/* Internal Procedure to create, initiate, and entry-activate a segment. */

get_unique_segment:
     proc (segment_suffix, segment_ptr, aste_ptr, segment_size, rcode);

dcl  segment_suffix char (*);
dcl  segment_ptr ptr;
dcl  aste_ptr ptr;
dcl  segment_size fixed bin;
dcl  rcode fixed bin (35);

dcl  seg_name char (32);


	seg_name = unique_chars_ (proc_id) || "." || segment_suffix;
	call append$branchx (">system_library_1", seg_name, RW_ACCESS_BIN, seg_rb, "*.*.*", /* The acl term effects us if this is not the Initializer */
	     0, 0, 0, rcode);
	if rcode ^= 0 then
	     if rcode ^= error_table_$namedup then return;

	call initiate$priv_init (">system_library_1", seg_name, "", 0, 0, segment_ptr, rcode);
	if rcode ^= 0 then return;

	call truncate$trseg (segment_ptr, 0, rcode);
	if rcode ^= 0 then return;

	aste_ptr = grab_aste$prewithdraw (segment_ptr, segment_size, rcode);
	if rcode ^= 0 then return;


     end get_unique_segment;

/* format: off */
%page; %include access_mode_values;
%page; %include sdw;
%page; %include apte;
%page; %include slt;
%page; %include stack_header;
/* format: on */
     end create_hproc;




		    deact_proc.pl1                  11/11/89  1107.3r w 11/11/89  0805.2       42885



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


deact_proc: proc;

/* Changed by E Stone to remove destroy entry and to convert to v2 on 05/74 */
/* Modified 05/78 by J. A. Bush to add cleanup for processor testing */
/* Modified September 1981 by J. Bongiovanni for tc_util */

dcl  code fixed bin (35);

dcl  save_ring fixed bin (3),				/* validation level */
    (sstp, pds_astep) ptr,
     name char (32) aligned;

dcl  delentry$dfile entry (char (*) aligned, char (*) aligned, fixed bin (35)),
     del_dir_tree entry (char (*) aligned, char (*) aligned, fixed bin (35)),
     unique_chars_ entry (bit (*) aligned) returns (char (15) aligned),
     level$get entry returns (fixed bin (3)),
     level$set entry (fixed bin (3)),
     pxss$stop_wakeup entry (bit (36) aligned, fixed bin),
     tc_util$process_status entry (ptr),
     pxss$empty_t ext entry (ptr),
     deactivate_segs ext entry (ptr),
     reconfig$destroy_cpu_test_env entry,
     ioam_$process_release entry (bit (36) aligned);

dcl  error_table_$action_not_performed fixed bin (35) ext,
     sst_seg$ fixed bin ext;

dcl (addr, ptr) builtin;

dcl 1 process_info based (pi_ptr) aligned,		/* structure used to transfer accounting data */
    2 processid bit (36),
    2 page_faults fixed bin (35),
    2 aptep ptr,
    2 ex_state fixed bin,
    2 mp_state fixed bin,
    2 last_block_time fixed bin (71),
    2 cpu_time_used fixed bin (71),
    2 paging_measure fixed bin (71),
    2 virtual_cpu_time fixed bin (71),
    2 reserved fixed bin (71);

dcl 1 info aligned like process_info;





	% include apte;
% include scs;

/*  */

/* The entry destroy_process_begin initiates the destruction of a process by stopping it
   in such a way that when the process stops it will send a wakeup to the process specified
   in apte.term_processid. The wakeup will be over the channel apte.term_channel. When the wakeup
   is received by the driving process (Answering Service?) the entry destroy_process_finish
   is called to return the final process statistics and to clean up the APT entry.
   As a final step destroy_process_finish deletes the process directory of the
   process just destroyed. */

destroy_process_begin: entry (pi_ptr, code);

dcl  pi_ptr ptr;

	info.processid = pi_ptr -> process_info.processid; /* get ID OF PROCESS TO STOP */
	call pxss$stop_wakeup (info.processid, info.ex_state); /* stop it */
	if info.ex_state = 0 then code = error_table_$action_not_performed;
	else code = 0;				/* return non-zero code only if already stopped */
	return;

/* * * * * * * *  * * * * * * * * * * * * * * * */

destroy_process_finish: entry (pi_ptr, code);

	info.processid = pi_ptr -> process_info.processid; /* get the process ID */
	call tc_util$process_status (addr (info));		/* get the goods for the process */
						/* check for stopped process */
	if ^((info.ex_state = 5) & (info.mp_state = 1)) then do;
	     code = error_table_$action_not_performed;	/* return non-zero code only if not stopped */
	     return;
	end;
	sstp = addr (sst_seg$);
	pds_astep = ptr (sstp, info.aptep -> apte.asteps.pds); /* get pointer to pds for the process */
	call deactivate_segs (pds_astep);		/* deactivate the process */
	info.aptep -> apte.lock_id = ""b;		/* clear out the lock id */
	info.aptep -> apte.processid = ""b;		/* and the process id */
	call pxss$empty_t (info.aptep);		/* give back the APT entry */
	call ioam_$process_release (info.processid);	/* free any devices assigned to this process */
	if scs$reconfig_lock = info.processid then	/* is this process testing a processor? */
	     call reconfig$destroy_cpu_test_env;	/* release CPU and SCU resources */
	name = unique_chars_ (info.processid);		/* get the PDIR name */
	save_ring = level$get ();			/* get (save) the validation level */
	call level$set (0);				/* do del_dir_tree from ring 0 */
	call del_dir_tree (">process_dir_dir", name, code);
	if code = 0 then
	     call delentry$dfile (">process_dir_dir", name, code);
	call level$set (save_ring);			/* restore validation level */
	pi_ptr -> process_info = info;		/* copy back accounting information */
	return;

     end deact_proc;




		    deactivate_segs.pl1             11/11/89  1107.3r w 11/11/89  0805.2       56943



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


deactivate_segs: proc (a_pds_astep);

/* DEACTIVATE_SEGS -- remove all traces of a stopped process from the system */

/* Modified by R. Bratt 2/11/75 to lock the ast before attempting to delete trailers
   and to avoid attempting to delete trailers for hardcore segment numbers
   modified April 1975 by R. Bratt for new KST / RNT system
   modified April 1975 by R. Bratt for new access in KST / SDW scheme
   modified June 1976 by B. Greenberg to leave KST visible in trailer crashes.
   modified 06/76 by D. Vinograd to handle backup_abs_seg.
   modified Oct 31 76 by Greenberg for pc$truncate_deposit_all (stop losing dseg pages).
   modified 02/22/77 by THVV for dsegs with branches
   Modified 03/21/81, W. Olin Sibert, for ADP PTWs and get_ptrs_$given_sdw
   Modified 04/16/81, WOS, for sdw_util_, and to remove obsolete PDS unwiring code.
   Modified March 1982, J. Bongiovanni, to make sure KST exists before using it
   */

dcl  a_pds_astep pointer parameter;

dcl  asp pointer;					/* Pointer to abs_seg$ (overlays assorted segmets) */
dcl  drsp pointer;					/* Pointer to dir_seg$ (overlays the dead KST) */
dcl (dstep, kst_astep, pds_astep, seg_astep) pointer;	/* Assorted ASTEPs */
dcl  tsdw fixed bin (71);
dcl  tsdwp pointer;
dcl  rdstep bit (18) aligned;
dcl (highseg, hcscnt, rel_dstep, i) fixed bin;
dcl  sdw_address fixed bin (26);
dcl  sdwp pointer;

dcl  bit18 bit (18) aligned based;
dcl  based_ptr ptr based;
dcl  sdwa (0 : 1023) fixed bin (71) aligned based;	/* DSEG overlay */

dcl  abs_seg$ fixed bin external static;
dcl  backup_abs_seg$ external static;
dcl  dir_seg$ fixed bin ext external static;

dcl  pds$dstep bit (18) external static;
dcl  sst_seg$ external static;

dcl  check_trailer entry (fixed bin) returns (bit (1) aligned);
dcl  get_ptrs_$given_astep entry (ptr) returns (fixed bin (71));
dcl  get_ptrs_$given_sdw entry (pointer) returns (pointer);
dcl  grab_aste$release entry (ptr);
dcl  grab_aste$release_prewithdraw entry (ptr);
dcl  lock$lock_ast entry ();
dcl  lock$unlock_ast entry ();
dcl  pmut$swap_sdw entry (ptr, ptr);
dcl  setfaults$deltrailer entry (ptr, fixed bin (17), fixed bin (17));
dcl  sdw_util_$get_address entry (pointer, fixed bin (26));
dcl  syserr entry options (variable);

dcl (baseno, ptr, rel, addr, fixed, null) builtin;

/*  */

	pds_astep = a_pds_astep;			/* copy argument */
	asp = addr (abs_seg$);			/* get needed pointers */
	drsp = addr (dir_seg$);
	tsdwp = addr (tsdw);
	tsdw = get_ptrs_$given_astep (pds_astep);	/* get pointer to PDS of process being deactivated */
	call pmut$swap_sdw (asp, tsdwp);		/* make abs_seg point to the PDS */

	rdstep = ptr (asp, rel (addr (pds$dstep))) -> bit18; /* get dstep from the PDS */
	dstep = ptr (addr (sst_seg$), rdstep);		/* get a pointer to the DSEG ASTE */
	kstp = ptr (asp, rel (addr (pds$kstp))) -> based_ptr; /* get pointer in HIS process to KST */

	tsdw = get_ptrs_$given_astep (dstep);		/* look at the DSEG */
	call pmut$swap_sdw (asp, tsdwp);		/* make the ABS-SEG work */

	if kstp ^= null () then do;
	     kst_astep = get_ptrs_$given_sdw (addr (asp -> sdwa (fixed (baseno (kstp), 18))));
	     tsdw = get_ptrs_$given_astep (kst_astep);	/* make abs_seg point to the KST */
	     call pmut$swap_sdw (drsp, tsdwp);
	     highseg = drsp -> kst.highest_used_segno;	/* copy highseg from the KST header */
	     hcscnt = drsp -> kst.lowseg;		/* get the hardcore seg count for later */
	     call grab_aste$release (kst_astep);		/* Release the KST aste */
	end;

/* Used to unwire any wired PDS pages here, but since the PDS is no longer used as a ring zero stack,
   there is no need to do this any more. First page won't be wired, either, because process is stopped,
   and has been unloaded. */

	call grab_aste$release_prewithdraw (pds_astep);	/* Release the PDS aste */

	if kstp ^= null () then do;
	     rel_dstep = fixed (rdstep, 18);		/* get rel(dstep) for deltrailer call */
	     tsdw = get_ptrs_$given_astep (dstep);	/* make the abs_seg point to the descriptor segment */
	     call pmut$swap_sdw (asp, tsdwp);
	     call lock$lock_ast;
	     do i = hcscnt + 1 to highseg,		/* loop through the KST entries */
		fixed (baseno (addr (backup_abs_seg$)), 18); /* And the backup_abs_seg, just in case */

		sdwp = addr (asp -> sdwa (i));
		call sdw_util_$get_address (sdwp, sdw_address);
		if sdw_address ^= 0 then do;
		     seg_astep = get_ptrs_$given_sdw (sdwp);
		     call setfaults$deltrailer (seg_astep, i, rel_dstep); /* delete the trailer */
		end;
	     end;

/* this check has been disabled for efficiency considerations, and beecause the
   class of software problems which caused it to go off have all been fixed.
   It should be made enablable by a tuning parameter if it is felt to be
   needed in the future.
   */

	     if "0"b then
		if check_trailer (rel_dstep) then
		     call syserr (1, "deactivate_segs: unflushed trailer");

	     call lock$unlock_ast;
	end;

/* Done with dseg */

	call grab_aste$release_prewithdraw (dstep);	/* release the DSEG aste */

	tsdw = 0;
	call pmut$swap_sdw (asp, tsdwp);		/* Clean up dseg */
	call pmut$swap_sdw (drsp, tsdwp);
	return;

%page; %include aste;
%page; %include kst;

/*  */

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   deactivate_segs: unflushed trailer

   S: $crash

   T: $run

   M: After destroying a process, the system found that some system trailer
   (specifying connection of that process to some segment) still exists
   for that process in str_seg. This indicates that some segment was
   improperly disconnected from the process at some time. $err

   A: $recover

   END MESSAGE DOCUMENTATION */

     end deactivate_segs;




		    get_process_usage.pl1           11/11/89  1107.3r   11/11/89  0805.2       21555



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


get_process_usage:
     procedure (process_usage_pointer, code);

/*

   Last Modified:

   09/17/76 by R. Bratt to add seg_fault, bound_fault, vtoc_read, and vtoc_write meters.
   01/08/85 by Keith Loepere to delete pd_page_faults.
*/

declare  code fixed bin (35),
         pds$apt_ptr ext pointer,
         pds$cpu_time fixed bin (71) ext,
         pds$virtual_delta fixed bin (71) ext,
         pds$page_waits fixed bin (35) ext,
         pds$segment_faults fixed bin (35) ext,
         pds$bounds_faults fixed bin (35) ext,
         pds$vtoc_reads fixed bin (35) ext,
         pds$vtoc_writes fixed bin (35) ext,
         clock_ entry returns (fixed bin (52));

/*  */

	process_usage.number_can_return = 9;		/* current number we can return */
	code = 0;					/* currently no error code can be returned */
	aptep = pds$apt_ptr;

	if number_wanted < 1 then return;
	process_usage.cpu_time = clock_ ()-pds$cpu_time;

	if number_wanted < 2 then return;
	process_usage.paging_measure = apte.paging_measure;

	if number_wanted < 3 then return;
	process_usage.page_faults = pds$page_waits;

	if number_wanted < 4 then return;
	process_usage.pd_faults = 0;			/* paging device */

	if number_wanted < 5 then return;
	process_usage.virtual_cpu_time = clock_ () - pds$cpu_time - pds$virtual_delta;

	if number_wanted < 6 then return;
	process_usage.segment_faults = pds$segment_faults;

	if number_wanted < 7 then return;
	process_usage.bounds_faults = pds$bounds_faults;

	if number_wanted < 8 then return;
	process_usage.vtoc_reads = pds$vtoc_reads;

	if number_wanted < 9 then return;
	process_usage.vtoc_writes = pds$vtoc_writes;


	return;

/*  */

%include apte;

/*  */

%include process_usage;

     end;




		    grab_aste.pl1                   11/11/89  1107.3r w 11/11/89  0805.2       59400



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


grab_aste: procedure (segptr, a_len, rcode) returns (ptr);

/*  This  procedure  is  responsible for forcibly activating segments.  The I/O
Buffer  Manager  uses  the  _io entries, which also clean up the segment w.r.t.
cache  control.   The  directory containing the segment must not be locked when
grab_aste is called.

Bernard Greenberg,   May 10, 1974

*/
/* 5/8/75 by BSG for NSS */
/* 4/26/77 by BSG for aste.ddnp */
/* 12/1/78 by BSG for not crashing on activate errors */
/* 1/82 BIM for dir write lock to get exclusive lock */

dcl	(segptr,				/* pointer to segment.   KST-recognized segment number */
	 a_astep) pointer;			/* argument astep of segment  on release calls. */

dcl	(rcode,				/* return error code */
	 code,				/* code from called routines */
	 word) fixed bin (35);		/* used for touching  seg */

dcl	do_io bit (1);			/* flag for _io entry */
dcl	prewithdraw bit (1);		/* flag for page prewithdrawing */
dcl	segno fixed bin (17);		/* segno for syserr calls */
dcl	dp ptr;				/* ptr to dir */

dcl	(null, baseno, ptr, fixed) builtin;

dcl	based_word (0:262143) fixed bin (35) based;
dcl	(len, a_len) fixed bin (18);
dcl	pno fixed bin;				/* Page number when prewithdrawing seg */

dcl	error_table_$dirseg fixed bin (35)  ext;

dcl	sum$getbranch entry (ptr, bit (36) aligned,  ptr, fixed bin (35)),
	lock$unlock_ast entry,
	activate entry (ptr, fixed bin (35)) returns (ptr),
	lock$dir_unlock entry (ptr),
	setfaults$cache entry (ptr, bit (1) aligned),
	syserr entry options (variable),
	syserr$error_code entry options (variable);

/**/
%include dir_entry;
%include aste;
/**/


	do_io = "0"b;				/* set flag for no  cache  business */
	prewithdraw = "0"b;
	go to grab_join;

grab_aste_io: entry (segptr, a_len, rcode) returns (ptr);

	do_io = "1"b;				/* set cache flags flag */
	prewithdraw = "0"b;
	go to grab_join;

prewithdraw: entry (segptr, a_len, rcode) returns (ptr);

	do_io = "0"b;
	prewithdraw = "1"b;

grab_join:
	segno = fixed (baseno (segptr), 17);		/* get segment number forr syserr calls */

	len = divide (a_len + 1023, 1024, 17, 0);	/* len = NUMBER OF PAGES in request */


	call sum$getbranch (segptr, (36)"1"b /* WRITE */, ep, code);	/* access  entry, and lock dir. Root and
						  mylock are not acceptable */

/* The point of locking the directory is so that nobody else can try to activate the
	segment while we try. Boundfaults and segfaults in this state are acceptable. */

	if code ^= 0 then do;			/* no errors are acceptable */
	     rcode = code;				/* pass the buck */
	     return (null());
	end;
	dp = ptr (ep, 0);				/* get dir ptr for unlock call */
	if ep -> entry.dirsw then do;			/* we do not take kindly to ehs'ing dirs */
	     call lock$dir_unlock (dp);
	     rcode = error_table_$dirseg;		/* operation not allowed for dirs */
	     return (null());
	end;

	astep = activate (ep, code);			/* Force to be active. Must have
						   large enough ASTE. */

	if astep = null then do;			/* Could be disk offline, etc. */
	     call lock$dir_unlock (dp);
	     rcode = code;
	     return (null ());
	end;

	if astep -> aste.ehs then
		call syserr (1, "grab_aste: Attempt to re-use seg ^o", segno);

	astep -> aste.ddnp = "1"b;			/* Don't deposit null pages- this protects
						   against deactivation, but boundsfaults go thru,
						   and segment moves reproduce the withdrawals! */

	call lock$unlock_ast;			/* Unlock AST to allow segmoves and boundsfaults */

	if prewithdraw then pno = 1;
	else pno = len;				/* Get prewithdraw range */

	do pno = pno to len by 1;			/* Touch all pages */
	     word = segptr -> based_word ((pno - 1) * 1024);	/* Cause allocation */
						/* aste.ddnp prevents against deallocation */
	end;

	astep = activate (ep, code);
	if astep = null then call syserr$error_code (1, code, "grab_aste: failed to reactivate ^p", ep);

	astep -> aste.ddnp = prewithdraw;		/* Conditionally turn off ddnp */

	astep -> aste.ehs = "1"b;			/* set entry hold active */

	if do_io then do;				/* if used for i/o, must disencache  */
	     astep -> aste.any_access_on = "0"b;	/* put in non-encached state */
	     astep -> aste.write_access_on,
	     astep -> aste.inhibit_cache = "1"b;	/* and make sure it stays there. */
	     call setfaults$cache (astep, "0"b);	/* take it out of current caches */
	end;

	call lock$unlock_ast;
	call lock$dir_unlock (dp);	/* unlock dir, now that ehs is on */
	rcode = 0;				/* all is ok */

	return (astep);				/* return ast entry  ptr */

/**/
release_io:	entry (a_astep);			/* entry to un-disencache and de-ehs */
	do_io  = "1"b;
	prewithdraw = "0"b;
	go to release_join;

release_prewithdraw: entry (a_astep);			/* Release nondepositable segments as ssch */

	prewithdraw = "1"b;
	do_io = "0"b;
	go to release_join;

release:	entry (a_astep);
	do_io = "0"b;
	prewithdraw = "0"b;

release_join:
	astep = a_astep;				/* copy arg */
	if ^astep -> aste.ehs then
	     call syserr (1, "grab_aste: Unprotected segment:  astep = ^p", astep);
						/* must have ehs on */
	astep -> aste.ehs = "0"b;			/* turn off ehs */
	if do_io then astep -> aste.inhibit_cache = "0"b; /* resume standard cache control */
	if prewithdraw then astep -> aste.ddnp = "0"b;
	return;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   grab_aste: Attempt to reuse segno SSS

   S: $crash

   T: $run

   M: A call has been made to force active a segment already forced active.
   This indicates an inconsistency in the programming of the supervisor.
   $err

   A: $recover
   $notify

   Message:
   grab_aste: failed to reactivate PPPP ERRORMESSAGE

   S: $crash

   T: $run

   M: $err

   A: $recover
   $notify

   Message:
   grab_aste: Unprotected segment: astep = AAA

   S: $crash

   T: $run

   M: An attempt was made to release from forced activity a segment (whose
   AST entry is at AAA) which was not even in a state of forced activity.
   $err

   A: $inform
   $recover

   END MESSAGE DOCUMENTATION */

end;




		    init_proc.pl1                   11/11/89  1107.3r w 11/11/89  0804.6      145989



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

/* format: style4 */
init_proc: proc;

/* This program is the first program executed (in ring 0) in a user, absentee, or
   daemon process. It is entered from special code in pxss via a return pointer
   left in the stack by build_template_pds. It is also called explicitly during
   initialization to get the initializer process into the user ring.

   Last modified (date and reason):
   8/15/74  by S.Webber --  completely recoded to make references to the pit.

   76/04/29 by T. Casey to fix bug in implementation of "-initproc path,direct",
   *		allow path to be relative to homedir,
   *		and to replace all instances of call syserr (2,...) (print with alarm and terminate process) by
   *		call syserr (4,...) or (3,...) (log, or print with alarm), followed by
   *		direct calls to terminate_proc$init_failure with a relevant error_table_ code.
   77/03/29 by M. Weaver to call makestack explicitly because of moving search rules to user ring
   79/03/01 by B. Margulies to set the working dir BEFORE calling makestack
   79/03/05 by B. Margulies to never set the working directory for users without
   v_init_proc.
   79/17/06 by B. Margulies to fix uninitialized variable bug introduced by
   above.
   79/07/14 by Mike Grady for ring 0 stack sharing
   81/10/05 by B. Margulies for new call_out mechanism.
   81/11/23 by B. Margulies for new initial procedure.
   84/11/05 by K. Loepere to rename terminate to terminate_.
   Modified 1984-11-11 by E. Swenson for IPC event channel validation.
   Here we set the value of apte.ipc_r_factor.
*/

/* Automatic */

dcl  (pp, caller_ptr) ptr;
dcl  (i, j) fixed bin;
dcl  (d_len, e_len, hd_len, less_thans, po_len) fixed bin;
dcl  code fixed bin (35);
dcl  dirname char (168);
dcl  initial_proc char (32);
dcl  temp fixed bin (71);

/* Entries */

dcl  makestack entry (fixed bin);
dcl  fs_search$set_wdir entry (char (*), fixed bin (35));
dcl  terminate_$noname entry (ptr, fixed bin (35));
dcl  pmut$set_mask entry (fixed bin (71), fixed bin (71));
dcl  level$set entry (fixed bin);
dcl  (syserr, syserr$error_code) entry options (variable);
dcl  terminate_proc$init_failure entry (fixed bin (35));
dcl  initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  initialize_kst entry;
dcl  pathname_am$initialize ext entry;
dcl  call_outer_ring_ entry (ptr, char (*), char (*), fixed bin (3), fixed bin (35));

/* External */

dcl  scs$open_level fixed bin (71) ext;
dcl  pds$stack_0_ptr ptr ext;
dcl  pds$stacks (0:7) ptr ext;
dcl  pds$process_dir_name char (32) aligned ext;
dcl  pds$process_group_id char (32) aligned ext;
dcl  pds$initial_ring fixed bin ext;
dcl  pds$apt_ptr pointer external;
dcl  error_table_$badpath ext fixed bin (35);
dcl  error_table_$bad_process_type ext fixed bin (35);

/* Constants */

dcl  (addr, index, length, null, reverse, rtrim, search, substr, verify) builtin;
%page;
/* First get a pointer to the PIT. Do this with a call to initiate since we know our process directory name */

	call pathname_am$initialize ();		/* initialize associative memory before doing anything */
	call initialize_kst;			/* before initiate can be called we must have a KST */

	pds$stacks (0) = pds$stack_0_ptr;

	call level$set (pds$initial_ring);		/* set user ring validation level before initiating */
	call pmut$set_mask (scs$open_level, temp);
						/* Now dispatch on the process type */

/* our goal is to establish wdir before calling makestack, so as to allow
   the user to substitute a signal_ or unwinder_ if she has v_init_proc.
   In order to do this we must initiate pit to check attribute.
   Luckily, if you call initiate without a refname it doesnt attempt to
   use the rnt, which isnt there yet. We would like to call initiate with
   the refname of "pit_", but as it is we will have to leave that for the
   user ring to do. */

	call initiate ((pds$process_dir_name), "pit", "", (0), (0), pp, code);
	if pp = null then do;
	     call syserr$error_code (3, code, "init_proc: could not get pointer to pit for ^a", pds$process_group_id);
	     call terminate_proc$init_failure (code);
	end;

	if pp -> pit.process_type = 0 then		/* initializer */
	     initial_proc = "system_startup_";

	else if pp -> pit.process_type < 4 then		/* interactive, absentee, or daemon */
	     initial_proc = "initialize_process_";

	else do;
	     call syserr$error_code (3, "init_proc: bad process type (^d) given for ^a",
		pp -> pit.process_type, pds$process_group_id);
	     call terminate_proc$init_failure (error_table_$bad_process_type);
	end;

	if initial_proc ^= "system_startup_" then	/* skip this setting for initializer as vol may not be there */
	     if pp -> pit.at.vinitproc then		/* if user is allowed to have his own process overseer */
		call fs_search$set_wdir (pp -> pit.homedir, (0)); /* set initial working dir to homedir */
						/* Otherwise avoid
						   * setting wdir, so user can't violate vinitproc restriction
						   * by putting a copy of xxxx_init_admin_ in his homedir */

/* The error code from fs_search is ignored; if we can't
   * set a working dir we do the best we can without one */

	call makestack (pds$initial_ring);		/* create stack, RNT and search rules */


/* Now initialize more of the process */

/* * Now get a pointer to the initial procedure - the first one to be executed in the user's initial ring.
   *
   * The default initial procedure for a user is user_init_admin_ for an interactive process, or absentee_init_admin_
   * for an absentee process. The proper one was selected above (its name being stored in initial_proc) as a function
   * of the process type. The initial procedure calls the login responder (also known as the process overseer).
   *
   * The default process overseer for a user is process_overseer_.
   *
   * It is possible for a procedure to be specified, either in the user's pdt entry, or by the user on the login line,
   * to be called instead of one of these two default procedures. The keyword "initproc" is used to identify this
   * procedure in both cases, and the keyword "direct" is used to indicate that the procedure is to be called directly,
   * in place of the default initial procedure, rather than being called by the default initial procedure
   * in place of the default process overseer. It is the "direct" case which we must check for here.
   *
   * By default, we do not use the referencing_dir search rule when searching for the initial procedure. This
   * allows a user to have an initial procedure of the same name as the default, in his home directory, and have
   * it used instead of the installed one. This will only happen if the user has the vinitproc attribute,
   * since, to enforce vinitproc, we put off setting his working directory to his home directory until
   * after we get the pointer to the initial procedure, if he does not have that attribute.
*/

	caller_ptr = null;				/* caller_ptr points to something in the referencing directory */

/* * The implementation of the "direct" feature is being changed, in stages.
   * Originally, this procedure was to scan for the string ",direct" at the end of the process overseer name,
   * and upon finding it, eliminate that string, and call the procedure specified by the remainder of the pathname, directly.
   * Then, the switch, pit.dont_call_init_admin was defined, and parts of the answering service were changed to
   * check for the string ",direct", and upon finding it, eliminate it from the pathname and turn on that switch.
   * However, some parts of the answering service do not check for the string or set the switch, so for now,
   * this procedure must check for both indications, and must be sure to eliminate the string ",direct" from the pathname
   * before attempting to get a pointer to the segment, even when the switch is found to be on.
   * The lines that check for ",direct" may be deleted after all parts of the answering service have been changed to
   * eliminate that string from the pathname and turn on the switch.
*/

	po_len = -1 + index (pp -> pit.login_responder, ",direct"); /* look for ",direct" */
	if po_len >= 0 then goto direct;		/* ",direct" is there, and
						   po_len is the length of the pathname that preceeds it */

	if pp -> pit.dont_call_init_admin then do;	/* check for the "direct" option */
						/* compute length of pathname without trailing blanks */
	     po_len = length (rtrim (pp -> pit.login_responder));

direct:						/* come here if ",direct" is in the process overseer pathname */

/* If string contains any ">" or "<" characters, it is a pathname */
	     e_len = -1 + search (reverse (substr (pp -> pit.login_responder, 1, po_len)), "<>"); /* see if it does */

	     if e_len >= 0 then do;			/* it is a pathname, and e_len is the length of the entryname */
		d_len = po_len - e_len - 1;		/* compute length of dirname part */

/* * Since expand_path_ is not available in ring zero, and it does not have
   * an ideal interface for use in this stage of process initialization anyway,
   * we do the equivalent pathname parsing in-line. This algorithm is copied from
   * expand_path_, modified to avoid unnecessary generality.
*/

		initial_proc = substr (pp -> pit.login_responder, d_len + 2, e_len); /* copy the entryname */
		if substr (pp -> pit.login_responder, 1, 1) = ">" then /* if we have a full pathname */
		     dirname = substr (pp -> pit.login_responder, 1, d_len); /* just copy the directory portion */

		else do;				/* relative pathname - build dirname, using pit.homedir */
		     hd_len = length (pp -> pit.homedir) - verify (reverse (pp -> pit.homedir), " ") + 1;
						/* compute length of home directory */
		     less_thans = -1 + verify (substr (pp -> pit.login_responder, 1, d_len + 2), "<");
						/* count leading "<"s */
						/* if there is nothing but "<"s before the entry name, the verify
						   gives the index of the first char of the entry name,
						   and the -1 makes the less_than count correct */
		     if index (substr (pp -> pit.login_responder, 1 + less_thans, d_len - less_thans + 1), "<") > 0 then do;
						/* if any non-leading less thans, bad syntax in path */
bad_path:			call syserr (4, "init_proc: bad syntax in initial procedure name: ^a for ^a",
			     pp -> pit.login_responder, pds$process_group_id);
			call terminate_proc$init_failure (error_table_$badpath);
		     end;

		     do i = 1 to less_thans;		/* if there are no less thans, this loop is skipped */
			j = index (reverse (substr (pp -> pit.homedir, 1, hd_len)), ">");
						/* back up thru "less_thans" components and ">"s */
			if j = 0 then		/* if no more left, too many "<"s */
			     goto bad_path;		/* just say bad path - don't bother with details */
			hd_len = hd_len - j;	/* shorten hd len by length of component and its leading ">" */
		     end;				/* end less thans loop */

		     if hd_len > 166 then		/* just a formality */
			goto bad_path;
		     if hd_len + d_len - less_thans + e_len + 2 > 168 then /* not just a formality */
			goto bad_path;		/* path too long */

/* now build the directory portion of the pathname */

		     if hd_len > 0 then		/* if the less thans did not get us back to the root */
			substr (dirname, 1, hd_len) = substr (pp -> pit.homedir, 1, hd_len);
		     if d_len - less_thans > 0 then do; /* if <dir>ent rather than <ent */
			substr (dirname, hd_len + 1, 1) = ">"; /* fill in ">dir" */
			substr (dirname, hd_len + 2) = substr (pp -> pit.login_responder, less_thans + 1, d_len - less_thans);
		     end;

		end;				/* end relative pathname */


/* * Try to initiate the segment specified by that pathname. Note that the pointer to it goes into caller_ptr,
   * which is used below, in the call to call_outer_ring_, to indicate the referencing directory.
*/

		call initiate (dirname, initial_proc, initial_proc, 0, 0, caller_ptr, code);
		if caller_ptr = null then do;		/* code could be error_table_$segknown if process is prelinked */
		     call syserr$error_code (4, code, "init_proc: can not get pointer to initial procedure: ^a>^a for ^a",
			dirname, initial_proc, pds$process_group_id);
		     call terminate_proc$init_failure (code);
		end;
	     end;					/* end pathname */

/* End of in-line expand_path_   */

	     else initial_proc = substr (pp -> pit.login_responder, 1, po_len); /* must be an entry name */

	end;					/* end dont_call_init_admin (call process overseer directly) */

	call terminate_$noname (pp, code);		/* terminate the pit */

/**** The following code sets the value of apte.ipc_r_factor used in
      conjunction with apte.ipc_r_offset for IPC event channel
      validation.  apte.ipc_r_offset was set in act_proc, and
      apte.ipc_r_factor is set here to allow for an unpredictable delay
      between setting the two values.  This makes it difficult to
      guess the value of apte.ipc_r_factor given the value of
      apte.ipc_r_offset.

      Note we are modifying our own apte here.  This should be ok since
      we can be sure that no one else will attempt to modify this value,
      and that the apte is not going anywhere while we are executing
      here in ring-0. */

	aptep = pds$apt_ptr;
	apte.ipc_r_factor =
	     binary (substr (bit (binary (clock (), 54), 54), 19, 36), 35);

/* Now call out. this program does all the work of snapping the link */
/* caller_ptr will be nonnull if there was a pathname */

	call call_outer_ring_ (caller_ptr, initial_proc, initial_proc, (pds$initial_ring), code);

	if code ^= 0 then do;
	     call syserr$error_code (4, code, "init_proc: can not call out to initial procedure: ^a for ^a",
		initial_proc, pds$process_group_id);
	     call terminate_proc$init_failure (code);
	end;

/* format: off */
%page; %include apte;
%page; %include pit;
%page; %include user_attributes;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   init_proc: could not get pointer to pit for PERSON.PROJ.T ERROR_MESSAGE

   S:	$beep

   T:	$run

   M:	The answering service has created
   the process directory for a new process incorrectly.
   The user cannot be logged in.

   A:	$contact


   Message:
   init_proc: bad process type (N) given for PERSON.PROJ.T

   S:	$beep

   T:	$run

   M:	The answering service has specified an
   unknown integer in the process type field.
   Incorrect arguments were passed to hphcs_$create_proc.
   The user cannot be logged in.

   A:	$contact


   Message:
   init_proc: bad syntax in initial procedure name: STRING for PERSON.PROJ.T

   S:	$log

   T:	$run

   M:	An illegal initial procedure name was specified for the user.
   The user may have given an incorrect -po argument, or the project's PDT may be wrong.
   No process is created.

   A:	$ignore


   Message:
   init_proc: can not get pointer to initial procedure: PATH for PERSON.PROJ.T ERROR_MESSAGE

   S:	$log

   T:	$run

   M:	The supervisor could not initiate the specified initial procedure PATH.
   The process overseer may be in invalid form, inaccessible, or missing.
   The user may have given an incorrect -po argument, or the project's PDT may be incorrect.

   A:	$ignore


   Message:
   init_proc: can not call out to initial procedure: NAME for PERSON.PROJ.T ERROR_MESSAGE

   S:	$log

   T:	$run

   M:	The supervisor could not snap a link to NAME$NAME.
   The process overseer may be in invalid form, inaccessible, or missing.
   The user may have given an incorrect -po argument, or the project's PDT may be incorrect.

   A:	$ignore


   END MESSAGE DOCUMENTATION */
/* format: on */

     end init_proc;




		    initialize_kst.pl1              11/11/89  1107.3r w 11/11/89  0805.3       29385



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

initialize_kst: proc ();

/* Initialize_kst is called during system initialization and process creation
   to initialize the Known Segment Table and the Reference Name Table.

   LAST MODIFIED:
   Feb 1983 by E. N. Kittlitz to set kst.allow_256K_connect for inzr
   Nov 1979 by Mike Grady to set pds$max_lot_size to kst size for inzr
   June 1979 by Mike Grady to not set stack_base_segno to pds for stack sharing
   September 1977 by B. Greenberg to keep Initialhzer KST below initsegs during initialization.
   March 1977 by M. Weaver to move rnt, search rule initialization to makestack
   October 1975 by R. Bratt to not preinitialize all kstes
   October 1975 by R. Bratt for prelinking
   March 1975 by R. Bratt for the new KST / RNT

   USAGE: - - - call initialize_kst();

   */

% include kst;
% include slt;

dcl (baseno, addr, fixed, string) builtin;


dcl  first_time bit (1),
     this_is_initializer bit (1),
     highseg fixed bin,
     i fixed bin;

dcl  kst_seg$ ext,
     slt$ ext,
     pds$max_lot_size (0:7) fixed bin ext,
     pds$processid bit (36) aligned ext,
     tc_data$initializer_id bit (36) aligned ext,

     dseg$ (0: 1) fixed bin (71) ext,
     active_all_rings_data$stack_base_segno fixed bin (18) ext, /* segno of first stack segment */
    (active_all_rings_data$hcscnt, active_all_rings_data$max_segno) ext fixed bin (17),
     pds$ fixed bin ext;


	kstp = addr (kst_seg$);			/* Get a pointer to the KST seg */
	this_is_initializer = (pds$processid = tc_data$initializer_id); /* set initializer flag */

	if this_is_initializer then
	     if kst.lowseg ^= 0 then
	          first_time = "0"b;
	     else first_time = "1"b;

	if this_is_initializer & first_time then do;
	     highseg = addr (slt$) -> slt.first_init_seg - 1;
	     kst.allow_256K_connect = "1"b;
	end;
	else highseg = active_all_rings_data$max_segno;

	if this_is_initializer & ^first_time then do;
	     kst.highseg = highseg;			/* Expand mx limit, init segs gone. */
	     pds$max_lot_size (*) = highseg + 1;
	     return;
	end;

	pds$kstp = kstp;				/* initialize pointer to kst */
	if string (kst.prelinked_ring) = "0"b
	then do;					/* only initialize if not prelinked process */
	     kst.lowseg = active_all_rings_data$hcscnt;
	     if kst.highseg = 0 then kst.highseg = highseg;
	     kst.highest_used_segno = kst.lowseg + 7;
	     kst.free_list = "0"b;
						/* reserve kstes for stacks */
	     do i = kst.lowseg to kst.lowseg + 7;
		kst.kst_entry (i).fp = (18)"1"b;
		kst.kst_entry (i).segno = i;
	     end;
	end;

	return;



     end initialize_kst;




		    stop_process.pl1                11/11/89  1107.3r w 11/11/89  0805.3       16047



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


stop_process: proc (a_process_id);

/* Procedure used by a process to put itself into "stopped" state.
   Called by process-overseer on new_proc and logout.

   Changed to crash system if caller is initializer - E Stone Aug 1974
   Converted to PL/I, C Garman, 3 Feb 1971.

   */

dcl a_process_id bit (36) aligned;
dcl  process_id bit (36) aligned,
     istate fixed bin;

dcl  pds$process_id bit (36) aligned ext,
     tc_data$initializer_id bit (36) aligned ext;

dcl syserr entry options (variable);

dcl  pxss$stop entry (bit (36) aligned, fixed bin);

	process_id = a_process_id;			/* Copy input */

	if process_id = pds$process_id then do;		/* See if proper process */

	     if process_id = tc_data$initializer_id then	/* Might as well end it all */
		call syserr (1, "stop_process: attempt to stop initializer process");

	     call pxss$stop (process_id, istate);

	end;					/* That's all folks! */

/* BEGIN MESSAGE DOCUMENTATION

Message:
stop_process: attempt to stop initializer process

S:	$crash

T:	$run

M:	$err

A:	$recover


END MESSAGE DOCUMENTATION */

     end stop_process;




		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
