implementation module scheduler


import	StdBool, StdList, StdTuple
import	osevent, ossystem, ostime, ostoolbox
import	commondef, devicefunctions, iostate, processstack, roundrobin, timertable, world
from	StdProcessDef		import :: ProcessInit
from	StdPSt				import accPIO, appPIO
from	StdProcessAttribute	import isProcessKindAttribute


::	*Environs
	=	{	envsEvents		:: !*OSEvents
		,	envsWorld		:: !*World
		}
::	*Context
	=	{	cEnvs			:: !*Environs			// The global environments
		,	cProcessStack	:: !ProcessStack		// The global process stack
		,	cMaxIONr		:: !SystemId			// The global maximum system number
		,	cProcesses		:: !*CProcesses			// All processes
		,	cModalProcess	:: !Maybe SystemId		// The SystemId of the interactive process that has a modal window
		,	cReceiverTable	:: !*ReceiverTable		// The global receiver-process table
		,	cTimerTable		:: !*TimerTable			// The table of all currently active timers
		,	cIdTable		:: !*IdTable			// The table of all bound Ids
		,	cOSTime			:: !OSTime				// The current OSTime
		,	cIdSeed			:: !Int					// The global id generating number (actually the World)
		,	cOSToolbox		:: !*OSToolbox			// The toolbox environment
		}

schedulerFatalError :: String String -> .x
schedulerFatalError rule message
	= error rule "scheduler" message


/*	Retrieval operations:			*/

//	On Context:

contextGetProcessStack :: !Context -> (!ProcessStack,!Context)
contextGetProcessStack context=:{cProcessStack}
	= (cProcessStack,context)

contextGetProcesses :: !Context -> (!CProcesses,!Context)
contextGetProcesses context=:{cProcesses}
	= (cProcesses,{context & cProcesses=emptyRR})

contextGetSleepTime :: !Context -> (!Int,!Context)
contextGetSleepTime context=:{cTimerTable=tt,cReceiverTable}
	# (maybe_sleep,tt)		= getTimeIntervalFromTimerTable tt
	# (maybe_receiver,rt)	= getActiveReceiverTableEntry cReceiverTable
	  sleep					= if (isJust maybe_receiver) OSNoSleep						// a receiver with a non-empty message queue exists
			  				 (if (isJust maybe_sleep)	(snd (fromJust maybe_sleep))	// a timer with given interval is waiting
			  				 							//OSNoSleep)	// DvA: need to test here wether tracking or not...
			  				 							OSLongSleep)					// neither a receiver nor timer
	= (sleep,{context & cTimerTable=tt,cReceiverTable=rt})

contextGetOSEvents :: !Context -> (!OSEvents,!Context)
contextGetOSEvents context=:{cEnvs=envs=:{envsEvents=es}}
	= (es,{context & cEnvs={envs & envsEvents=osNewEvents}})

contextSetOSEvents :: !(!OSEvents,!Context) -> Context
contextSetOSEvents (osEvents,context=:{cEnvs=envs})
	= {context & cEnvs={envs & envsEvents=osEvents}}


//	On RuntimeState:

rsIsBlocked :: !RuntimeState -> (!Bool,SystemId)
rsIsBlocked (Blocked ioid)	= (True, ioid)
rsIsBlocked _				= (False,nullSystemId)

rsIsClosed :: !RuntimeState -> Bool
rsIsClosed Closed			= True
rsIsClosed _				= False


//	Starting an interactive process.

initContext :: !*(ProcessInit (PSt .l)) !String !.l !DocumentInterface !ProcessKind !*World -> (!Context,!*OSToolbox)
initContext ioDefInit ioDefAbout local documentInterface ioKind world
	# w						= loadWorld world
	# world					= storeWorld w world
	# initEnvs				= {envsEvents=osNewEvents,envsWorld=world}
	# tb					= osInitToolbox OSNewToolbox
	# (ostime,tb)			= osGetTime tb
	= (	{	cEnvs			= initEnvs
		,	cProcessStack	= ioStack
		,	cMaxIONr		= initSystemId
		,	cProcesses		= toRR [] [openLocalIO ioState local]
		,	cModalProcess	= initModalId
		,	cReceiverTable	= initialReceiverTable
		,	cTimerTable		= initialTimerTable
		,	cIdTable		= initialIdTable
		,	cOSTime			= ostime
		,	cIdSeed			= w
		,	cOSToolbox		= OSNewToolbox
		}
	  ,	tb
	  )
where
	initModalId				= Nothing
	show					= ioKind==InteractiveProcess
	ioStack					= [{psId=initSystemId,psShow=show,psKind=ioKind}]
	ioState					= createNewIOSt [] ioDefInit ioDefAbout initSystemId Nothing Nothing ShareGUI documentInterface ioKind

initContext` :: !*World -> (!Context,!*OSToolbox)
initContext` world
	# w					= loadWorld world
	# world				= storeWorld w world
	# initEnvs			= {envsEvents=osNewEvents,envsWorld=world}
	# tb				= osInitToolbox OSNewToolbox
	# (ostime,tb)		= osGetTime tb
	= (	{	cEnvs			= initEnvs
		,	cProcessStack	= ioStack
		,	cMaxIONr		= initSystemId
		,	cProcesses		= toRR [] []
		,	cModalProcess	= initModalId
		,	cReceiverTable	= initialReceiverTable
		,	cTimerTable		= initialTimerTable
		,	cIdTable		= initialIdTable
		,	cOSTime			= ostime
		,	cIdSeed			= w
		,	cOSToolbox		= OSNewToolbox
		}
	  ,	tb
	  )
where
	initModalId			= Nothing
	ioStack				= []

createNewIOSt :: ![ProcessAttribute (PSt .l)] !*(ProcessInit (PSt .l)) String !SystemId !(Maybe SystemId) 
					!(Maybe GUIShare) !Bool !DocumentInterface !ProcessKind
	-> IOSt .l
createNewIOSt pAtts ioDefInit ioDefAbout nr parentId guishare isSubProcess documentInterface ioKind
	= emptyIOSt nr parentId guishare documentInterface ioKind pAtts ioDefInit Nothing


//	Handling events until termination of all interactive processes.

handleEvents :: !Context !*OSToolbox -> (!Context,!*OSToolbox)
handleEvents context tb
	# (_,context)	= handleContextOSEvent osNullEvent context
	= osHandleEvents terminate contextGetOSEvents contextSetOSEvents contextGetSleepTime handleContextOSEvent (context,tb)
where
	terminate :: !Context -> (!Bool,!Context)
	terminate context=:{cProcessStack}
		= (isEmpty cProcessStack,context)


//	Closing a final context. 

closeContext :: !Context !*OSToolbox -> *World
closeContext {cProcessStack,cEnvs={envsWorld}} tb
	| isEmpty cProcessStack	= storeWorld 42 envsWorld
	| otherwise				= schedulerFatalError "closeContext" "not a final Context"


//	Handling events while condition holds.

chandleEvents :: !(St Context Bool) !Context !*OSToolbox -> (!Context,!*OSToolbox)	// PA: swapped order of last 2 args and result
chandleEvents cond context tb
	= osHandleEvents terminate contextGetOSEvents contextSetOSEvents contextGetSleepTime handleContextOSEvent (context,tb)
where
	terminate :: !Context -> (!Bool,!Context)
	terminate context
		# (continue,context)	= cond context
		= (not continue,context)

handleContextOSEvent :: !OSEvent !Context -> (![Int],!Context)
handleContextOSEvent osEvent context=:{cEnvs=envs=:{envsEvents=osEvents},cProcessStack,cProcesses,cReceiverTable,cTimerTable,cOSTime,cOSToolbox}
//	PA: shift the time in the timertable.
	# (ostime,tb)				= osGetTime cOSToolbox
	  timeshift					= toInt (ostime-cOSTime)
	  timertable				= shiftTimeInTimerTable timeshift cTimerTable
//	PA: determine whether a TimerEvent or ASyncMessage can be generated
	  (schedulerEvent,receivertable,timertable,osEvents)
	  							= toSchedulerEvent osEvent cReceiverTable timertable cOSTime osEvents
	  processes					= resetRR cProcesses
	  (_,oldTopIO)				= topShowProcessShowState cProcessStack
	# context					= {context & cEnvs			= {envs & envsEvents=osEvents}
										   , cProcesses		= processes
										   , cReceiverTable	= receivertable
										   , cTimerTable	= timertable
										   , cOSTime		= ostime
										   , cOSToolbox		= tb
								  }
	# (schedulerEvent,context)	= handleEventForContext False schedulerEvent context
	  replyToOS					= case schedulerEvent of
	  								(ScheduleOSEvent _ reply)	-> reply
	  								_							-> []
	# (newStack,context)		= contextGetProcessStack context
	  (newTopIOVis,newTopIO)	= topShowProcessShowState newStack
	| oldTopIO==newTopIO || not newTopIOVis
		= (replyToOS,context)
	| otherwise
		# (processes,context)	= contextGetProcesses context
		# (newStack,processes)	= activateTopOfGroups newTopIO newStack (resetRR processes)
		= (replyToOS,{context & cProcessStack=newStack,cProcesses=processes})


/*	PA: new function:
	in case a non-urgent, removable system event has been caught, check if a TimerEvent or ASyncMessage 
	can be generated instead. If both a TimerEvent and an ASyncMessage are available, use the OSTime to 
	decide which one to choose.
*/
zerotimelimit :: OSTime
zerotimelimit =: fromInt (max 1 (OStickspersecond/20))

//import StdDebug,dodebug

toSchedulerEvent :: !OSEvent !*ReceiverTable !*TimerTable !OSTime !*OSEvents -> (!SchedulerEvent,!*ReceiverTable,!*TimerTable,!*OSEvents)
toSchedulerEvent osevent receivertable timertable osTime osEvents
	| eventIsUrgent
//		= trace_n (showEvent osevent) (schedulerEvent,receivertable,timertable,osEvents)
		= (schedulerEvent,receivertable,timertable,osEvents)
	# (maybe_timer,timertable)		= getTimeIntervalFromTimerTable timertable
	  (zerotimer,interval)			= fromJust maybe_timer
//	  (zerotimer`,interval)			= fromJust maybe_timer
//	  zerotimer						= isJust maybe_timer && zerotimer`
	  sure_timer					= isJust maybe_timer && interval<=0
	  (maybe_receiver,receivertable)= getActiveReceiverTableEntry receivertable
	  sure_receiver					= isJust maybe_receiver
	| not sure_timer && not sure_receiver
		= (schedulerEvent,receivertable,timertable,osEvents)
	# (timerEvent,timertable`)		= toTimerEvent timertable
	  (asyncEvent,receivertable`)	= toASyncEvent (fromJust maybe_receiver) receivertable
	# osEvents`						= checkOSZeroTimerEvent zerotimer osTime osevent osEvents
//	# osEvents`						= checkOSZeroTimerEvent maybe_timer osTime osevent osEvents
	| sure_timer && sure_receiver
//		# osEvents`						= checkOSZeroTimerEvent zerotimer osTime osevent osEvents
		| isEven (toInt osTime)
			= (timerEvent,receivertable,timertable`,osEvents`)
		// otherwise
			= (asyncEvent,receivertable`,timertable,osEvents`)
	| sure_timer
//		# osEvents`						= checkOSZeroTimerEvent zerotimer osTime osevent osEvents
		= (timerEvent,receivertable,timertable`,osEvents`)
	| otherwise
		= (asyncEvent,receivertable`,timertable,osEvents)
where
	eventIsUrgent					= osEventIsUrgent osevent
	schedulerEvent					= ScheduleOSEvent osevent []

//	In case the original event is a virtual zero timer event:
//		check if another should be inserted in the OSEvents to circumvent the event system call. 
//	In case the original event is a non urgent event:
//		check if an initial virtual zero timer event must be inserted to start circumventing event system calls.
	checkOSZeroTimerEvent :: !Bool !OSTime !OSEvent !*OSEvents -> *OSEvents
//	checkOSZeroTimerEvent :: !(Maybe (Bool,Int)) !OSTime !OSEvent !*OSEvents -> *OSEvents
	checkOSZeroTimerEvent zerotimer osTime osevent osEvents
//	checkOSZeroTimerEvent maybe_timer osTime osevent osEvents
		| not zerotimer
			= osEvents
		| isNothing maybe_zerotimer_start
			= osAppendEvents [createOSZeroTimerEvent osTime] osEvents
		| osTime-zerotimer_start<=zerotimelimit
			= osAppendEvents [osevent] osEvents
		| otherwise
			= osEvents
/*
		| isJust maybe_zerotimer_start && zerotimer
			| osTime-zerotimer_start<=zerotimelimit
				= osAppendEvents [osevent] osEvents
			// otherwise
				= osEvents
		| isNothing maybe_zerotimer_start && zerotimer
			= osAppendEvents [createOSZeroTimerEvent osTime] osEvents
//		| osTime-zerotimer_start<=zerotimelimit
//			= osAppendEvents [osevent] osEvents
		| otherwise
			= osEvents
*/
	where
//		(zerotimer,_)			= fromJust maybe_timer
		maybe_zerotimer_start	= getOSZeroTimerStartTime osevent
		zerotimer_start			= fromJust maybe_zerotimer_start
	
//	The receiver for which an ASyncMessage is generated is placed behind all other receivers, 
//	creating a round-robin order. Its asynchronous message queue length field is decreased.
	toASyncEvent :: !Id !*ReceiverTable -> (!SchedulerEvent,!*ReceiverTable)
	toASyncEvent rid receivertable
		#! (maybeRTE,receivertable)	= getReceiverTableEntry rid receivertable
		#! rte						= fromJust maybeRTE
		#! rte						= {rte & rteASMCount=rte.rteASMCount-1}
		#! receivertable			= setReceiverTableEntry rte (snd (removeReceiverFromReceiverTable rid receivertable))
		= (ScheduleMsgEvent (ASyncMessage {asmRecLoc=rte.rteLoc}),receivertable)
	
//	The timer for which a TimerEvent is generated is determined by getActiveTimerInTable.
//	This function already takes care of fairness using a round robin scheme.
	toTimerEvent :: !*TimerTable -> (!SchedulerEvent,!*TimerTable)
	toTimerEvent timertable
		# (maybeTimerEvent,timertable)	= getActiveTimerInTimerTable timertable
		= (ScheduleTimerEvent (fromJust maybeTimerEvent),timertable)


handleEventForContext :: !Bool !SchedulerEvent !Context -> (!SchedulerEvent,!Context)
handleEventForContext eventDone schedulerEvent context=:{cProcesses=processes}
	# (notodo,processes)	= notodoRR processes
	| notodo
		= (schedulerEvent,{context & cProcesses=processes})
	# (process,processes)	= getcurrentRR processes
	# (quitted,process)		= processQuitted process
	# (isModal,process)		= processModal   process
	| quitted && not isModal
		= handleEventForContext eventDone schedulerEvent {context & cProcesses=processes}
	| quitted
		= handleEventForContext eventDone schedulerEvent {context & cProcesses=adddoneRR process processes}
	| otherwise
		# (eventDone,schedulerEvent,process,context)
						= handleEventForLocalIO eventDone schedulerEvent process {context & cProcesses=processes}
		= handleEventForContext eventDone schedulerEvent {context & cProcesses=adddoneRR process context.cProcesses}
where
	processQuitted :: !CProcess -> (!Bool,!CProcess)
	processQuitted localIO=:{localIOSt}
		# (closed,ioState) = ioStClosed localIOSt
		= (closed,{localIO & localIOSt=ioState})
	
	processModal :: !CProcess -> (!Bool,!CProcess)
/*	processModal localIO=:{localIOSt}
		# (optModal,ioState)= ioStGetIOIsModal localIOSt
		# (myId,ioState)	= ioStGetIOId ioState
		= (isJust optModal && myId==fromJust optModal,{localIO & localIOSt=ioState})
*/	processModal localIO=:{localIOSt}
		# (notEmpty,ioState)	= ioStHasDevices localIOSt
		= (notEmpty,{localIO & localIOSt=ioState})

handleEventForLocalIO :: !Bool !SchedulerEvent !CProcess !Context
					 -> (!Bool,!SchedulerEvent,!CProcess,!Context)
handleEventForLocalIO eventDone schedulerEvent {localState=opt_local,localIOSt=ioState} context
	# (runtime,ioState)						= ioStGetRuntimeState ioState
	| fst (rsIsBlocked runtime)
		= (eventDone,schedulerEvent,{localState=opt_local, localIOSt=ioState},context)
	# (initIO,ioState)						= ioStGetInitIO ioState
	# (dummies,pState)						= cSwitchIn (fromJust opt_local) context ioState
	# pState								= initIO pState
	# (ioKind,pState)						= accPIO ioStGetProcessKind pState
	| ioKind==VirtualProcess
		# pState							= closeVirtualProcess pState
		# (local,context,ioState)			= cSwitchOut dummies pState
		= (eventDone,schedulerEvent,{localState=Just local,localIOSt=ioState},context)
	# (closed,pState)						= accPIO ioStClosed pState
	| closed
		# (local,context,ioState)			= cSwitchOut dummies pState
		= (eventDone,schedulerEvent,{localState=Just local,localIOSt=ioState},context)
	| otherwise
		# (deviceFunctions,pState)			= accPIO ioStGetDeviceFunctions pState
		  ioFunctions						= [(df.dEvent,df.dDoIO) \\ df<-deviceFunctions]
		# (eventDone,schedulerEvent,pState)	= handleEventForDevices ioFunctions eventDone schedulerEvent pState
		# (local,context,ioState)			= cSwitchOut dummies pState
		= (eventDone,schedulerEvent,{localState=Just local,localIOSt=ioState},context)
where
	closeVirtualProcess :: !(PSt .l) -> PSt .l
	closeVirtualProcess pState=:{io}
		# (subids,ioState)		= ioStGetSubProcessIds io
		| not (isEmpty subids)
			= {pState & io=ioState}
		| otherwise
			# (ioStack,ioState)	= ioStGetProcessStack ioState
			# (nr,ioState)		= ioStGetIOId ioState
			  (_, ioStack)		= removeProcessShowState nr ioStack
			# ioState			= ioStSetProcessStack ioStack ioState
			# ioState			= removeIOIdFromParentProcess nr ioState
			# ioState			= ioStSetRuntimeState Closed ioState
			= {pState & io=ioState}

cSwitchIn :: !.l !Context !(IOSt .l) -> (!(![*World],!CProcesses),!PSt .l)
cSwitchIn local {cEnvs={envsEvents,envsWorld},cProcessStack,cMaxIONr,cProcesses,cModalProcess,cReceiverTable,cTimerTable,cIdTable,cOSTime,cIdSeed} ioState
	# ioState				= ioStSetProcessStack cProcessStack ioState
	# ioState				= ioStSetEvents envsEvents ioState
	# ioState				= ioStSetMaxIONr cMaxIONr ioState
	# (ioContext,ioState)	= ioStSwapIO ([envsWorld],cProcesses) ioState
	# ioState				= ioStSetIOIsModal cModalProcess ioState
	# ioState				= ioStSetIdTable cIdTable ioState
	# ioState				= ioStSetReceiverTable cReceiverTable ioState
	# ioState				= ioStSetTimerTable cTimerTable ioState
	# ioState				= ioStSetOSTime cOSTime ioState
	# ioState				= ioStSetIdSeed cIdSeed ioState
	# pState				= {ls=local,io=ioState}
	= (ioContext,pState)

cSwitchOut :: !(![*World],!CProcesses) !(PSt .l) -> (!.l,!Context,!IOSt .l)
cSwitchOut ioContext {ls,io}
	# (ostime,   ioState)		= ioStGetOSTime			io
	# (tt,       ioState)		= ioStGetTimerTable		ioState
	# (idseed,   ioState)		= ioStGetIdSeed			ioState
	# (ridlocs,  ioState)		= ioStGetReceiverTable	ioState
	# (idtable,  ioState)		= ioStGetIdTable		ioState
	# (modalId,  ioState)		= ioStGetIOIsModal		ioState
	# (ioContext,ioState)		= ioStSwapIO ioContext	ioState
	# (worlds,processes)		= ioContext
	# (maxIONr,  ioState)		= ioStGetMaxIONr		ioState
	# (ioStack,  ioState)		= ioStGetProcessStack	ioState
	# (es,	     ioState)		= ioStGetEvents			ioState
	# envs						= {envsEvents=es,envsWorld=hd worlds}
	# context					= {	cEnvs			= envs
								  ,	cProcessStack	= ioStack
								  ,	cMaxIONr		= maxIONr
								  ,	cProcesses		= processes
								  ,	cModalProcess	= modalId
								  ,	cReceiverTable	= ridlocs
								  ,	cTimerTable		= tt
								  ,	cIdTable		= idtable
								  ,	cOSTime			= ostime
								  ,	cIdSeed			= idseed
								  ,	cOSToolbox		= OSNewToolbox
								  }
	= (ls,context,ioState)

/*	handleEventForDevices in sequence lets the devices handle the scheduler event until it is handled
	or the process is terminated (ioStClosed returns True).
	Before handing over the event to the device DoIOFunction, the device first maps the event to a
	device event if possible using its EventFunction. 
*/	
handleEventForDevices :: ![(!EventFunction (PSt .l),!DoIOFunction (PSt .l))] !Bool !SchedulerEvent (PSt .l)
																		 -> (!Bool,!SchedulerEvent, PSt .l)
handleEventForDevices [(mapDeviceEvent,doDeviceIO):doIOs] eventDone schedulerEvent pState
	| eventDone
		= (eventDone,schedulerEvent,pState)
	# (closed,pState)				= accPIO ioStClosed pState
	| closed
		= (True,schedulerEvent,pState)
	# (forThisDevice,okDeviceEvent,schedulerEvent,pState)
									= mapDeviceEvent schedulerEvent pState
	| not forThisDevice
		= handleEventForDevices doIOs eventDone schedulerEvent pState
	| isNothing okDeviceEvent
		= handleEventForDevices doIOs True schedulerEvent pState
	| otherwise
		# (deviceEvent,pState)		= doDeviceIO (fromJust okDeviceEvent) pState
		# schedulerEvent			= mergeMsgEventIntoSchedulerEvent deviceEvent schedulerEvent
		= handleEventForDevices doIOs True schedulerEvent pState
where
	mergeMsgEventIntoSchedulerEvent :: !DeviceEvent !SchedulerEvent -> SchedulerEvent
	mergeMsgEventIntoSchedulerEvent (ReceiverEvent msgEvent) _	= ScheduleMsgEvent msgEvent
	mergeMsgEventIntoSchedulerEvent _ schedulerEvent			= schedulerEvent
handleEventForDevices _ eventDone schedulerEvent pState
	= (eventDone,schedulerEvent,pState)

handleOneEventForDevices :: !SchedulerEvent !(PSt .l) -> (!Bool,!SchedulerEvent,!PSt .l)
handleOneEventForDevices schedulerEvent pState
	# (deviceFunctions,pState)	= accPIO ioStGetDeviceFunctions pState
	  ioFunctions				= [(df.dEvent,df.dDoIO) \\ df<-deviceFunctions]
	= handleEventForDevices ioFunctions False schedulerEvent pState


/*	Creating interactive processes other than the initial interactive process.
	Throughout the I/O library it is assumed that all new process groups and all new data sharing
	processes are created AFTER the current interactive process. This is done for two reasons:
	-	locating offspring processes becomes more efficient (when you need to quit them). 
	-	it provides a simple additional means of communication between parent and child processes
		(piggybacking the Event` data item).
	Virtual processes (created with addVirtualProcess) evaluate only the initial actions. It is
	assumed by the system that the initial actions do not create any devices instances or set the 
	AppleMenuTitle. This MUST be taken care of by the system programmer (the system will abort if so). 
	Interactive processes (created with addInteractiveProcess) do create devices. 
*/

ShareGUI			:==	True
NotShareGUI			:==	False

//	Create a virtual process that will create other interactive processes.

addVirtualProcess :: !*(ProcessInit (PSt .l)) String .l !(PSt .l`) -> PSt .l`
addVirtualProcess ioDefInit ioDefAbout local pState
	# (nr,ioState)			= ioStNewMaxIONr pState.io
	# (parentId,ioState)	= ioStGetIOId					ioState
	# (guishare,ioState)	= getGUIShare     ShareGUI		ioState
	# ioState				= addSubProcessId ShareGUI nr	ioState
	# (ioStack, ioState)	= ioStGetProcessStack			ioState
	  ioStack				= pushProcessShowState {psId=nr,psShow=False,psKind=VirtualProcess} ioStack
	# ioState				= ioStSetProcessStack ioStack	ioState
	# (processes,ioState)	= ioStGetCProcesses				ioState
	# newIOSt				= createNewIOSt [] ioDefInit ioDefAbout nr (Just parentId) guishare ShareGUI NDI VirtualProcess
	# process				= openLocalIO newIOSt local
	# ioState				= ioStSetCProcesses (inserttodoRR process processes) ioState
	= {pState & io=ioState}


//	Create a data sharing interactive process.

addInteractiveProcess :: ![ProcessAttribute (PSt .l)] !*(ProcessInit (PSt .l)) String .l !Bool !DocumentInterface !(PSt .l`) -> PSt .l`
addInteractiveProcess pAtts ioDefInit ioDefAbout local isSubProcess documentInterface pState
	# (nr,ioState)			= ioStNewMaxIONr pState.io
	# (parentId,ioState)	= ioStGetIOId						ioState
	# (guishare,ioState)	= getGUIShare     isSubProcess		ioState
	# ioState				= addSubProcessId isSubProcess nr	ioState
	# (ioStack, ioState)	= ioStGetProcessStack				ioState
	  ioStack				= pushProcessShowState {psId=nr,psShow=True,psKind=InteractiveProcess} ioStack
	# ioState				= ioStSetProcessStack ioStack		ioState
	# (processes,ioState)	= ioStGetCProcesses					ioState
	  parent				= if isSubProcess (Just parentId) Nothing
	  pAtts					= filter (isProcessKindAttribute documentInterface) pAtts
	# newIOSt				= createNewIOSt pAtts ioDefInit ioDefAbout nr parent guishare isSubProcess documentInterface InteractiveProcess
	# process				= openLocalIO newIOSt local
	# ioState				= ioStSetCProcesses (inserttodoRR process processes) ioState
	= {pState & io=ioState}

openLocalIO :: !(IOSt .l) !.l -> CProcess
openLocalIO ioState local
	= {	localState	= Just local
	  ,	localIOSt	= ioState
	  }

getGUIShare :: !Bool !(IOSt .l) -> (!Maybe GUIShare,!IOSt .l)
getGUIShare isSubProcess ioState
	| not isSubProcess
		= (Nothing,ioState)
	# (guishare,ioState)	= ioStGetGUIShare ioState
	| isJust guishare
		= (guishare,ioState)
	# (ioKind,ioState)		= ioStGetProcessKind ioState
	| ioKind==VirtualProcess
		= (guishare,ioState)
	| otherwise
		= (guishare,ioState)

addSubProcessId :: !Bool !SystemId !(IOSt .l) -> IOSt .l
addSubProcessId isSubProcess nr ioState
	| not isSubProcess
		= ioState
	| otherwise
		# (subids,ioState)	= ioStGetSubProcessIds ioState
		  ioState			= ioStSetSubProcessIds [nr:subids] ioState
		= ioState


//	Make the proper interactive process active.

activateTopOfGroups :: !SystemId !ProcessStack !CProcesses -> (!ProcessStack,!CProcesses)
activateTopOfGroups topIONr ioStack processes
	# (emptytodo,processes)			= notodoRR processes
	| emptytodo
		= (ioStack,processes)
	# (process,processes)			= getcurrentRR processes
	  (activated,ioStack,process)	= activateTopProcess topIONr ioStack process
	| activated
		= (ioStack,inserttodoRR process processes)
	| otherwise
		# (ioStack,processes)		= activateTopOfGroups  topIONr ioStack processes
		= (ioStack,inserttodoRR process processes)
where
	activateTopProcess :: !SystemId !ProcessStack !CProcess -> (!Bool,!ProcessStack,!CProcess)
	activateTopProcess topIONr ioStack process=:{localIOSt=ioState}
		# (nr,ioState)			= ioStGetIOId ioState
		| nr<>topIONr
			= (False,ioStack ,{process & localIOSt=ioState})
		| otherwise
			# ioState			= ioStSetProcessStack ioStack ioState
			# (ioStack,ioState)	= ioStGetProcessStack ioState
			= (True,ioStack,{process & localIOSt=ioState})


/*	Quit this interactive or virtual process.
	It should be an impossible situation for the system to have to quit a blocked process (the guard should never hold).
	Quitting a process involves the following:
	-	Set the RuntimeState to Closed (quitProcess is the only function that does this)
	-	Force all sub processes to quit
	-	Inform the parent process about its termination
	-	Remove the process from the ProcessStack
	-	Close all devices
*/
quitProcess :: !(PSt .l) -> PSt .l
quitProcess pState
	# (rs,pState)					= accPIO ioStGetRuntimeState pState
	| fst (rsIsBlocked rs)
		= schedulerFatalError "quitProcess" "closeProcess applied to blocked process"
	| rsIsClosed rs
		= pState
	| otherwise
		# (deviceFunctions,pState)	= accPIO ioStGetDeviceFunctions pState
		# pState					= strictSeq [df.dClose \\ df<-deviceFunctions] pState
		# ioState					= ioStSetRuntimeState Closed     pState.io
		# (nr,ioState)				= ioStGetIOId                    ioState
		# (subids,ioState)			= ioStGetSubProcessIds           ioState
		# ioState					= quitSubProcesses subids        ioState
		# ioState					= removeIOIdFromParentProcess nr ioState
		# (ioStack,ioState)			= ioStGetProcessStack            ioState
		  (_,ioStack)				= removeProcessShowState nr      ioStack
		# ioState					= ioStSetProcessStack ioStack    ioState
		# (osdinfo,ioState)			= ioStGetOSDInfo                 ioState
		# ioState					= appIOToolbox (osCloseOSDInfo osdinfo) ioState
		= {pState & io=ioState}


/*	quitSubProcesses searches for all processes in the current process administration
	with the given ids. Each of these processes is forced to quit by setting the initialisation
	functions to [appPIO quitProcess]. In this way all recursive descendent processes will
	be quitted as well.
*/
quitSubProcesses :: ![SystemId] !(IOSt .l) -> IOSt .l
quitSubProcesses ids ioState
	# (processes,ioState)	= ioStGetCProcesses ioState
	  (_,processes)			= quitLocalSubProcesses ids processes
	# ioState				= ioStSetCProcesses processes ioState
	= ioState
where
	quitLocalSubProcesses :: ![SystemId] !CProcesses -> (![SystemId],!CProcesses)
	quitLocalSubProcesses ids processes
		| isEmpty ids
			= (ids,processes)
		| otherwise
			# (done,todo)	= fromRR processes
			  (ids,done)	= quitLocalSubProcesses` ids done
			  (ids,todo)	= quitLocalSubProcesses` ids todo
			= (ids,toRR done todo)
	where
		quitLocalSubProcesses` :: ![SystemId] !*[CProcess] -> (![SystemId],!*[CProcess])
		quitLocalSubProcesses` [] processes
			= ([],processes)
		quitLocalSubProcesses` ids []
			= (ids,[])
		quitLocalSubProcesses` ids [process=:{localState,localIOSt=ioState}:processes]
			# (ioid,ioState)		= ioStGetIOId ioState
			  (hadId,_,ids)			= remove ((==) ioid) nullSystemId ids
			| hadId
				# (subids,ioState)	= ioStGetSubProcessIds ioState
				# ioState			= ioStSetInitIO quitProcess ioState
				# process			= {localState=localState,localIOSt=ioState}
				# (ids,processes)	= quitLocalSubProcesses` (ids++subids) processes
				= (ids,[process:processes])
			| otherwise
				# process			= {localState=localState,localIOSt=ioState}
				# (ids,processes)	= quitLocalSubProcesses` ids processes
				= (ids,[process:processes])


/*	removeIOIdFromParentProcess searches for the parent process in the current process
	administration. It is a fatal error not to find this process. In the administration
	of the parent process the child process id is removed.
*/
removeIOIdFromParentProcess :: !SystemId !(IOSt .l) -> IOSt .l
removeIOIdFromParentProcess me ioState
	# (opt_parent,ioState)	= ioStGetParentId ioState
	| isNothing opt_parent
		= ioState
	# parent				= fromJust opt_parent
	# (locals,ioState)		= ioStGetCProcesses ioState
	# (done,locals)			= removeIOIdFromLocals me parent locals
	# ioState				= ioStSetCProcesses locals ioState
	| done
		= ioState
	| otherwise
		= schedulerFatalError "CloseProcess" "parent process could not be located"
where
	removeIOIdFromLocals :: !SystemId !SystemId !CProcesses -> (!Bool,!CProcesses)
	removeIOIdFromLocals me parent locals
		# (done,todo)			= fromRR locals
		  (removed,done)		= removeIOIdFromLocals` me parent done
		| removed
			= (removed,toRR done todo)
		| otherwise
			# (removed, todo)	= removeIOIdFromLocals` me parent todo
			= (removed,toRR done todo)
	where
		removeIOIdFromLocals` :: !SystemId !SystemId !*[CProcess] -> (!Bool,!*[CProcess])
		removeIOIdFromLocals` me parent [process=:{localState,localIOSt=ioState}:processes]
			# (ioid,ioState)			= ioStGetIOId ioState
			| parent==ioid
				# (subids,ioState)		= ioStGetSubProcessIds ioState
				  (_,_,subids)			= remove ((==) me) (dummy "removeIOIdFromLocals") subids
				# ioState				= ioStSetSubProcessIds subids ioState
				# process				= {localState=localState,localIOSt=ioState}
				= (True,[process:processes])
			| otherwise
				# process				= {localState=localState,localIOSt=ioState}
				# (removed,processes)	= removeIOIdFromLocals` me parent processes
				= (removed,[process:processes])
		removeIOIdFromLocals` _ _ _
			= (False,[])


//	Function threading operations:

::	SwitchError
	=	SwitchToYourself
	|	SwitchToDoesNotExist
	|	SwitchToReceiverDoesNotExist
	|	SwitchReceiverUnable
	|	SwitchEndsUpInDeadlock

/*	cswitchProcess processId msgEvent pstate switches to PSt identified by processId, lets that process 
	handle the msgEvent, and switches back to pstate.
	Nothing SwitchError is returned if no exceptions were detected. 
	Exceptions are:
	-	SwitchToYourself:				processId is the current PSt. 
	-	SwitchToDoesNotExist:			no current process can be identified by processId. 
	-	SwitchToReceiverDoesNotExist:	process  exists, but receiver doesn't.
	-	SwitchReceiverUnable:			receiver exists, but is not Able.
	-	SwitchEndsUpInDeadlock:			if this process would block for the process with 
										id processId to get unblocked, a deadlock would occur.
	In all exceptional cases the PSt remains unchanged.
	Observe that in case Nothing is returned, the ps PSt component may have changed value.
*/
cswitchProcess :: !SystemId !SchedulerEvent !(PSt .l) -> (!Maybe SwitchError,![SemiDynamic],!PSt .l)
cswitchProcess processId message pState
	| processId==returnId
		= (Just SwitchToYourself,    [],pState1)
	| not switchToExists
		= (Just SwitchToDoesNotExist,[],pState2)
	with
		context2						= {context1 & cProcesses=groups2}
		pState2							= switchToPSt typeIOSt returnId context2 local
	| inDeadlock
		= (Just SwitchEndsUpInDeadlock,[],pState2)
	with
		context2						= {context1 & cProcesses=groups3}
		pState2							= switchToPSt typeIOSt returnId context2 local
	| otherwise
		= (checkSyncMessageError message1,getSyncMessageResponse message1,pState2)
	with
		context2						= {context1 & cProcesses=groups3}
		(context3,_)					= chandleEvents (processIsBlocked processId) context2 OSNewToolbox
		(groups4,context4)				= contextGetProcesses context3
		context5						= {context4 & cProcesses=resetRR groups4}
		(message1,context6)				= handleEventForContext False message context5
		pState2							= switchToPSt typeIOSt returnId context6 local
where
	(returnId,pState1)					= accPIO ioStGetIOId pState
	(local,context,ioState)= switchFromPSt pState1
	(groups,context1)					= contextGetProcesses context
	ioState1							= ioStSetRuntimeState (Blocked processId) ioState
	(typeIOSt, ioState3)				= typeIsIOSt  ioState1
	blockedLocalIO						= {localState=Nothing,localIOSt=ioState3}
	groups1								= adddoneRR blockedLocalIO groups
	(switchToExists,groups2)			= turnRRToProcessInGroups processId groups1
	(inDeadlock,groups3)				= checkDeadlock  returnId processId groups2
	
	switchToPSt :: !(UnguardType (IOSt .l)) !SystemId !Context .l -> PSt .l
	switchToPSt typeIOSt returnId context=:{cProcesses} local
		# (_,groups)					= turnRRToProcessInGroups returnId cProcesses
		  (group,groups)				= getcurrentRR groups
		  (gDone,gToDo)					= fromRR groups
		  {localIOSt=blockedIO}			= group
		  blockedIO						= castType typeIOSt blockedIO
		  context						= {context & cProcesses=toRR gDone gToDo}
		  (_,pState)					= cSwitchIn local context (ioStSetRuntimeState Running blockedIO)
		= pState
	
	checkSyncMessageError :: !SchedulerEvent -> Maybe SwitchError
	checkSyncMessageError (ScheduleMsgEvent (SyncMessage {smError}))
		| isEmpty smError
			= Nothing
		| not (isSingleton smError)
			= schedulerFatalError "checkSyncMessageError" "more than one MessageError returned"
		| otherwise
			= case (hd smError) of
				ReceiverUnable	-> Just SwitchReceiverUnable
				ReceiverUnknown	-> Just SwitchToReceiverDoesNotExist
	checkSyncMessageError _
		= Nothing
	
	getSyncMessageResponse :: !SchedulerEvent -> [SemiDynamic]
	getSyncMessageResponse (ScheduleMsgEvent (SyncMessage {smResp}))
		= smResp
	getSyncMessageResponse _
		= []

typeIsIOSt :: !(IOSt .l) -> (UnguardType (IOSt .l),!IOSt .l)
typeIsIOSt ioState = (Unguard,ioState)

typeIsLocal :: !(IOSt .l) -> (UnguardType (Maybe .l),!IOSt .l)
typeIsLocal ioState = (Unguard,ioState)

//	PA: appContext added.
appContext :: !.(IdFun Context) !(PSt .l) -> PSt .l
appContext fun pState
	# (returnId,pState)			= accPIO ioStGetIOId pState
	# (local,context,ioState)	= switchFromPSt pState
	# (groups,context)			= contextGetProcesses context
	# (typeIOSt, ioState)		= typeIsIOSt  ioState
	# (typeLocal,ioState)		= typeIsLocal ioState
	# localIO					= {localState=Just local,localIOSt=ioState}
	# groups					= adddoneRR localIO groups
	# context					= {context & cProcesses=groups}
	# context					= fun context
	# (groups,context)			= contextGetProcesses context
	# context					= {context & cProcesses=resetRR groups}
	# pState					= switchToPSt typeIOSt typeLocal returnId context
	= pState

accContext :: !.(St Context .x) !(PSt .l) -> (!.x, !PSt .l)
accContext fun pState
	# (returnId,pState)			= accPIO ioStGetIOId pState
	# (local,context,ioState)	= switchFromPSt pState
	# (groups,context)			= contextGetProcesses context
	# (typeIOSt, ioState)		= typeIsIOSt  ioState
	# (typeLocal,ioState)		= typeIsLocal ioState
	# localIO					= {localState=Just local,localIOSt=ioState}
	# groups					= adddoneRR localIO groups
	# context					= {context & cProcesses=groups}
	# (x, context)				= fun context
	# (groups,context)			= contextGetProcesses context
	# context					= {context & cProcesses=resetRR groups}
	# pState					= switchToPSt typeIOSt typeLocal returnId context
	= (x, pState)

switchToPSt :: !(UnguardType (IOSt .l)) !(UnguardType (Maybe .l)) !SystemId !Context -> PSt .l
switchToPSt typeIOSt typeLocal returnId context=:{cProcesses}
	| not found				= schedulerFatalError "accContext" "interactive process not found"
	| closed				= snd (cSwitchIn (fromJust local1) {context1 & cModalProcess=Nothing} ioState2)
	| otherwise				= snd (cSwitchIn (fromJust local1)  context1 ioState2)
where
	(found,groups)			= turnRRToProcessInGroups returnId cProcesses
	(gDone,gToDo)			= fromRR groups
	(group,gToDo1)			= hdtl gToDo
	{localState=local,localIOSt=ioState}
							= group
	ioState1				= castType typeIOSt ioState
	local1					= castType typeLocal   local
	groups1					= toRR gDone gToDo1
	context1				= {context & cProcesses=groups1}
	(closed,ioState2)		= ioStClosed ioState1

switchFromPSt :: !(PSt .l) -> (!.l,!Context,!IOSt .l)
switchFromPSt pState
	= cSwitchOut ([],emptyRR) pState

turnRRToProcessInGroups :: !SystemId !*CProcesses -> (!Bool,!*CProcesses)
turnRRToProcessInGroups id gs
	= turnRRToProcess id (resetRR gs)
where
	turnRRToProcess :: !SystemId !*CProcesses -> (!Bool,!*CProcesses)
	turnRRToProcess id locals
		# (notodo,locals)	= notodoRR locals
		| notodo
			= (False,locals)
		# (local,locals)	= getcurrentRR locals
		  (found,local)		= turnRRToProcess` id local
		| found
			= (True,inserttodoRR local locals)
		| otherwise
			= turnRRToProcess id (adddoneRR local locals)
	where
		turnRRToProcess` :: !SystemId !*CProcess -> (!Bool,!*CProcess)
		turnRRToProcess` id l=:{localIOSt=ioState}
			# (ioid,ioState)	= ioStGetIOId ioState
			= (id==ioid,{l & localIOSt=ioState})


//	A deadlock situation arises if this process would be blocked.

checkDeadlock :: !SystemId !SystemId !*CProcesses -> (!Bool,!*CProcesses)
checkDeadlock returnId switchToId gs
	= checkDeadlock` [returnId] switchToId gs
where
	checkDeadlock` :: ![SystemId] !SystemId *CProcesses -> (!Bool,!*CProcesses)
	checkDeadlock` blockedprocs nextproc gs
		# ((nextprocfound,opt_id),gs)	= checkBlockedProcess nextproc gs
		| not nextprocfound
			= (False,gs)
		| isNothing opt_id
			= (False,gs)
		# nextproc						= fromJust opt_id
		  blockedprocs					= [nextproc:blockedprocs]
		  occurs						= contains ((==) nextproc) blockedprocs
		| occurs
			= (True, gs)
		| otherwise
			= checkDeadlock` blockedprocs nextproc gs

/*	checkBlockedProcess id groups
		locates the interactive process identified by id in groups and checks if the process is blocked.
		If this is the case then the id is returned of the process for which this process is waiting.
		If this is not the case, then no id is returned.
*/
checkBlockedProcess :: !SystemId !*CProcesses -> (!Result SystemId,!*CProcesses)
checkBlockedProcess nextproc groups
	= accessLocals (checkInLocal nextproc) groups
where
	checkInLocal :: !SystemId !*CProcess -> (!Result SystemId,!CProcess)
	checkInLocal nextproc localIO=:{localIOSt=ioState}
		# (blocked,ioState)	= checkProcess nextproc ioState
		= (blocked,{localIO & localIOSt=ioState})
	where
		checkProcess :: !SystemId !(IOSt .l) -> (!Result SystemId,!IOSt .l)
		checkProcess ioid ioState
			# (ioid`,ioState)		= ioStGetIOId ioState
			| ioid<>ioid`
				= ((False,Nothing),ioState)
			# (runtime,ioState)		= ioStGetRuntimeState ioState
			  (isBlocked,blockedFor)= rsIsBlocked runtime
			| isBlocked
				= ((True,Just blockedFor),ioState)
			| otherwise
				= ((True,Nothing),ioState)


/*	The process with SystemId id has a (Blocked id`) RuntimeState.
*/
processIsBlocked :: !SystemId !Context -> (!Bool,!Context)
processIsBlocked id context=:{cProcesses}
	# ((procfound,opt_id),groups)	= checkBlockedProcess id cProcesses
	  context						= {context & cProcesses=groups}
	| procfound						= (isJust opt_id,context)
	| otherwise						= (procfound,context)


::	Result r
	:==	(	!Bool			// object is found
		,	!Maybe r		// optional access information
		)

/*	Threading f::(IOSt .l .p) -> (Result r,IOSt .l .p) through *CProcesses 
	applies f to every IOSt member ioState of CProcesses until fst (f ioState) = (True,r) is done
	by defining the function gLocals:
	
		gLocals :: *CProcesses -> (Result r, *CProcesses)
		gLocals locals = accessLocals f locals
*/
accessLocals :: !(St CProcess (Result r)) !*CProcesses -> (!Result r,!*CProcesses)
accessLocals accLocal locals
	# (lsDone,lsToDo)	= fromRR locals
	  (rDone,lsDone) 	= accessLocalIOs accLocal lsDone
	| fst rDone
		= (rDone,toRR lsDone lsToDo)
	| otherwise
		# (rToDo,lsToDo)= accessLocalIOs accLocal lsToDo
		= (rToDo,toRR lsDone lsToDo)
where
	accessLocalIOs :: !(St CProcess (Result r)) ![*CProcess] -> (!Result r, ![*CProcess])
	accessLocalIOs accLocal [local:locals]
		# (r, local)		= accLocal local
		| fst r
			= (r, [local:locals])
		| otherwise
			# (rs,locals)	= accessLocalIOs accLocal locals
			= (rs,[local:locals])
	accessLocalIOs _ []
		= ((False,Nothing),[])

/*	The function castType is used to let the type checker assign the type
	determined by the first argument to the expression of the second argument. 
	This function contains abc code because it can't be typed conventionally. (RWS)
*/
::	UnguardType p
	=	Unguard

castType :: (UnguardType .p) .y -> .p
castType _ y = code {
	pop_a 1
	jmp_eval
	}
