Artifact c7946d77761f8f66bd61cea12daa4a4d73ee5688:

• File packages/interp/lib/process.tcl — part of check-in [37c510501f] at 2019-10-15 14:03:02 on branch trunk — list deep replace "struct" with "deep"

  interp process

  new package

  (user: pooryorick size: 2822)

#! /usr/bin/env tclsh

package require Thread

package require {ycl proc}
[yclprefix] proc alias [yclprefix]::proc::alias
alias [yclprefix]::proc::optswitch

package require {ycl list}
alias [yclprefix]::list::take


proc call {process cmd} {
	set call [namespace current]::processes::${process}::calls::[info cmdcount]
	namespace eval $call {}
	set varname ${call}::response
	set cmdprefix [::list ::apply [
		::list {coroutine process call args} {

		::tailcall $coroutine done $process $call
	} [namespace current]] [info coroutine] $process $call]
	set trace [::list $varname write $cmdprefix]
	set ${call}::trace $trace
	trace add variable {*}$trace
	set ${call}::caller [info coroutine]
	thread::send -async $process $cmd $varname
	yield
}


proc calls process {
	lsort -dictionary [namespace children processes::${process}::calls]
}


proc calls_interrupt {reason callers process status} {
	foreach caller $callers {
		$caller $reason $process $status
	}
}


proc cleanup {process reason status} {
	set callers [lmap call [calls $process] {
		namespace upvar $call caller caller
		set caller
	}]
	namespace delete processes::$process
	calls_interrupt $reason $callers $process $status
}


proc exited {process status} {
	cleanup $process exited $status
}


proc kill process {
	thread::release $process
	cleanup $process killed 127
}


proc list {} {
	lsort -dictionary [lmap process [namespace children processes] {
		namespace tail $process
	}]
}


variable doc::new {
	description {
		emulate a process a command in an interp in a separate thread
	}
}
proc new args {
	set kill 1
	while {[llength $args]} {
		take args opt
		optswitch $opt {
			config - cmd - kill - procname {
				take args $opt
			}
		}
	}
	set thread [thread::create]
	if {[info exists procname]} {
		upvar 1 $procname procvar
		set procvar $thread
	}
	thread::send $thread [string map [
		::list @controller@ [thread::id] @command@ "[
			::list [namespace current]] exited"] {

		::rename ::exit {}
		proc ::exit status {
			thread::send -async @controller@ "@command@ [thread::id] $status"
			thread::release
		}
	}]
	namespace eval processes::${thread}::calls {}
	if {[info exists config]} {
		call $thread $config
	}
	set res [call $thread $cmd]
	if {$kill} {
		kill $thread
	}
	return $res
}


proc yield {} {
	set args [lassign [::yieldto return -level 0 [info coroutine]] cstatus]
	switch $cstatus {
		done {
			lassign $args process call
			namespace upvar $call response response trace trace
			trace remove variable {*}$trace
			set res $response
			namespace delete $call
			return $res
		}
		exited - killed {
			lassign $args process status
			error [::list [::list process $cstatus] \
				process $process status $status]
		}
		default {
			error [::list {unknown call status} $cstatus]
		}
	}
}


namespace eval processes {}