rishi/scryer-prolog
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

get process_create working and add tests

Browse Source
This commit is contained in:
Bennet Bleßmann
2025-07-26 18:21:00 +02:00
committed by Bennet Bleßmann
parent 1120bcde29
commit dc08a4ab11
14 changed files with 223 additions and 91 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
build/instructions_template.rs
View File

@@ -539,6 +539,8 @@ enum SystemClauseType {
Shell,
#[strum_discriminants(strum(props(Arity = "8", Name = "$process_create")))]
ProcessCreate,
#[strum_discriminants(strum(props(Arity = "2", Name = "$process_id")))]
ProcessId,
#[strum_discriminants(strum(props(Arity = "3", Name = "$process_wait")))]
ProcessWait,
#[strum_discriminants(strum(props(Arity = "1", Name = "$process_kill")))]
@@ -1834,6 +1836,7 @@ fn generate_instruction_preface() -> TokenStream {
&Instruction::CallUnsetEnv |
&Instruction::CallShell |
&Instruction::CallProcessCreate |
&Instruction::CallProcessId |
&Instruction::CallProcessWait |
&Instruction::CallProcessKill |
&Instruction::CallProcessRelease |
@@ -2076,6 +2079,7 @@ fn generate_instruction_preface() -> TokenStream {
&Instruction::ExecuteUnsetEnv |
&Instruction::ExecuteShell |
&Instruction::ExecuteProcessCreate |
&Instruction::ExecuteProcessId |
&Instruction::ExecuteProcessWait |
&Instruction::ExecuteProcessKill |
&Instruction::ExecuteProcessRelease |

20
src/arena.rs
View File

@@ -20,6 +20,7 @@ use std::mem;
use std::mem::ManuallyDrop;
use std::net::TcpListener;
use std::ops::{Deref, DerefMut};
use std::process::Child;
use std::ptr;
use std::ptr::addr_of_mut;
use std::ptr::NonNull;
@@ -75,7 +76,8 @@ pub enum ArenaHeaderTag {
HttpResponse = 0b1000010,
PipeWriter = 0b1000011,
Dropped = 0b1000100,
PipeReader = 0b1000101,
PipeReader = 0b1001001,
ChildProcess = 0b1001010,
}
#[bitfield]
@@ -391,6 +393,19 @@ impl ArenaAllocated for HttpResponse {
}
}
impl ArenaAllocated for Child {
type Payload = ManuallyDrop<Self>;
#[inline]
fn tag() -> ArenaHeaderTag {
ArenaHeaderTag::ChildProcess
}
}
impl AllocateInArena<Child> for Child {
fn arena_allocate(self, arena: &mut Arena) -> TypedArenaPtr<Child> {
Child::alloc(arena, ManuallyDrop::new(self))
}
}
#[repr(C)]
#[derive(Debug)]
pub struct AllocSlab {
@@ -556,6 +571,9 @@ unsafe fn drop_slab_in_place(value: NonNull<AllocSlab>, tag: ArenaHeaderTag) {
ArenaHeaderTag::PipeWriter => {
drop_typed_slab_in_place!(PipeWriter, value);
}
ArenaHeaderTag::ChildProcess => {
drop_typed_slab_in_place!(Child, value);
}
ArenaHeaderTag::NullStream => {
unreachable!("NullStream is never arena allocated!");
}

17
src/heap_print.rs
View File

@@ -1789,6 +1789,23 @@ impl<'a, Outputter: HCValueOutputter> HCPrinter<'a, Outputter> {
(ArenaHeaderTag::Dropped, _value) => {
self.print_impromptu_atom(atom!("$dropped_value"));
}
(ArenaHeaderTag::ChildProcess, process) => {
let process_atom = atom!("$process");
if self.format_struct(max_depth, 1, process_atom) {
let atom = TokenOrRedirect::NumberFocus(max_depth, NumberFocus::Unfocused(Number::Fixnum(Fixnum::build_with(process.id()))), op);
let process_root = self.state_stack.pop().unwrap();
self.state_stack.pop();
self.state_stack.pop();
self.state_stack.push(atom);
self.state_stack.push(TokenOrRedirect::Open);
self.state_stack.push(process_root);
}
}
_ => {
}
);

10
src/lib/lists.pl
View File

@@ -7,7 +7,7 @@ List manipulation predicates
maplist/3, maplist/4, maplist/5, maplist/6,
maplist/7, maplist/8, maplist/9, same_length/2, nth0/3, nth0/4, nth1/3, nth1/4,
sum_list/2, transpose/2, list_to_set/2, list_max/2,
list_min/2, permutation/2]).
list_min/2, permutation/2, filter/3]).
/* Author: Mark Thom, Jan Wielemaker, and Richard O'Keefe
Copyright (c) 2018-2021, Mark Thom
@@ -538,3 +538,11 @@ perm([], []).
perm(List, [First|Perm]) :-
select(First, List, Rest),
perm(Rest, Perm).
%% filter(+Predicate, ?Xs1 ?Xs2).
%
% Succeeds if Xs2 is the list of elements X from Xs1 for which call(Pred, X) succeeds.
%
filter(_, [], []).
filter(Pred, [X1|XS1], XS) :- call(Pred, X1) -> filter(Pred, XS1, XS2), XS = [X1|XS2] ; filter(Pred, XS1, XS).

70
src/lib/process.pl
View File

@@ -1,5 +1,6 @@
:- module(process, [
process_create/3,
process_id/2,
process_release/1,
process_wait/2,
process_wait/3,
@@ -8,7 +9,7 @@
:- use_module(library(error)).
:- use_module(library(iso_ext)).
:- use_module(library(lists), [append/3, member/2, maplist/2, maplist/3, select/3]).
:- use_module(library(lists), [member/2, maplist/2, filter/3]).
%% process_create(+Exe, +Args:list, +Options).
@@ -20,7 +21,7 @@
% Options is a list consisting of the following options:
%
% * `cwd(+Path)` Set the processes working directory to `Path`
% * `process(-Pid)` `Pid` will be assigned the spawned processes process id
% * `process(-Process)` `Process` will be assigned a process handle for the spawned process
% * `env(+List)` Don't inherit environment variables and set the variables defined in `List`
% * `environment(+List)` Inherit environment variables and set/override the variables defined in `List`
% * `stdin(Spec)`, `stdout(Spec)` or `stderr(Spec)` defines how to redirect the spawned processes io streams
@@ -53,7 +54,7 @@ process_create(Exe, Args, Options) :-
([stdout], valid_stdio, stdout(std), stdout(Stdout)),
([stderr], valid_stdio, stderr(std), stderr(Stderr)),
([env, environment], valid_env, environment([]), Env),
([process], valid_process, process(_), process(Pid)),
([process], valid_uninit_process, process(_), process(Process)),
([cwd], valid_cwd, cwd("."), cwd(Cwd))
],
Options
@@ -62,21 +63,27 @@ process_create(Exe, Args, Options) :-
Stdout =.. Stdout1,
Stderr =.. Stderr1,
simplify_env(Env, Env1),
'$process_create'(Exe, Args, Stdin1, Stdout1, Stderr1, Env1, Cwd, Pid).
'$process_create'(Exe, Args, Stdin1, Stdout1, Stderr1, Env1, Cwd, Process).
%% process_id(+Process, -Pid).
%
process_id(Process, Pid) :-
valid_process(Process, process_id/2),
write(valid), nl,
must_be(var, Pid),
write(var), nl,
'$process_id'(Process, Pid).
%% process_wait(+Pid, Status).
%% process_wait(+Process, Status).
%
% See `process_create/3` with `Options = []`
%
process_wait(Pid, Status) :- process_wait(Pid, Status, []).
process_wait(Process, Status) :- process_wait(Process, Status, []).
%% process_wait(+Pid, Status, Options).
%% process_wait(+Process, Status, Options).
%
% Wait for the child process with `Pid` to exit.
%
% Only works for processes spawned with `process_create/3` that have not yet been release with `process_release/1`
% Wait for the process behind the process handle `Process` to exit.
%
% When the process exits regulary `Status` will be unified with `exit(Exit)` where `Exit` is the processes exit code.
% When the process exits was killed `Status` will be unified with `killed(Signal)` where `Signal` is the signal number that killed the process.
@@ -90,43 +97,42 @@ process_wait(Pid, Status) :- process_wait(Pid, Status, []).
%
% - timeout(infinite)
%
process_wait(Pid, Status, Options) :-
must_be(integer, Pid),
process_wait(Process, Status, Options) :-
valid_process(Process, process_wait/3),
must_be_known_options([timeout], [], Options),check_options(
[
([timeout], valid_timeout, timeout(infinite), timeout(Timeout))
],
Options
),
'$process_wait'(Pid, Exit, Timeout),
'$process_wait'(Process, Exit, Timeout),
Exit = Status.
valid_timeout(timeout(infinite)).
valid_timeout(timeout(0)).
%% process_kill(+Pid).
%% process_kill(+Process).
%
% Kill the child process identified by `Pid`.
% Kill the process using the process handle `Process`.
% On Unix this sends SIGKILL.
%
% Only works for processes spawned with `process_create/3` that have not yet been release with `process_release/1`
%
process_kill(Pid) :-
must_be(integer, Pid),
'$process_kill'(Pid).
process_kill(Process) :-
valid_process(Process, process_kill/1),
'$process_kill'(Process).
%% process_release(+Pid)
%% process_release(+Process)
%
% release child process object of the process identified by `Pid`
% wait for the process to exit (if not already) and release process handle `Process`
%
% It's an error if
% * the `Pid` is not associated with a child process created by `process_create/3`,
% * the child project object has already been released
% It's an error if `Process` is not a valid process handle
%
process_release(Pid) :-
process_wait(Pid, _),
'$process_release'(Pid).
process_release(Process) :-
valid_process(Process, process_release/1),
process_wait(Process, _),
'$process_release'(Process).
must_be_known_options(_, _, []).
@@ -142,16 +148,16 @@ must_be_known_options(Valid, Found, [X|XS]) :-
check_options([], _).
check_options([X | XS], Options) :-
(Kinds, Pred, Default, Choice) = X,
findall(P, find_option(Kinds, P, Options), Solutions),
filter(process:find_option(Kinds), Options, Solutions),
(
Solutions = [] -> Choice = Default;
Solutions = [Provided] -> call(Pred, Provided), Choice = Provided ;
error(evaluation_error(confliction_options), process_create/3)
error(evaluation_error(confliction_options, Solutions), process_create/3)
),
check_options(XS, Options).
find_option([Kind|_], Found, Options) :- Found =.. [Kind,_], member(Found, Options).
find_option([_|Kinds], Found, Options) :- find_option(Kinds, Found, Options).
find_option([Kind|_], Found) :- Found =.. [Kind,_].
find_option([_|Kinds], Found) :- find_option(Kinds, Found).
valid_stdio(IO) :- IO =.. [_, Arg],
(
@@ -179,7 +185,9 @@ valid_env_([N=V|ES]) :-
must_be(chars, V),
valid_env_(ES).
valid_process(process(Pid)) :- must_be(var, Pid).
valid_uninit_process(process(Process)) :- must_be(var, Process).
valid_process(Process, Context) :- var(Process) -> instantiation_error(Context) ; true.
valid_cwd(cwd(Cwd)) :- must_be(chars, Cwd).

8
src/machine/dispatch.rs
View File

@@ -4795,6 +4795,14 @@ impl Machine {
try_or_throw!(self.machine_st, self.process_create());
step_or_fail!(self, self.machine_st.p = self.machine_st.cp);
}
&Instruction::CallProcessId => {
try_or_throw!(self.machine_st, self.process_id());
step_or_fail!(self, self.machine_st.p += 1);
}
&Instruction::ExecuteProcessId => {
try_or_throw!(self.machine_st, self.process_id());
step_or_fail!(self, self.machine_st.p = self.machine_st.cp);
}
&Instruction::CallProcessWait => {
try_or_throw!(self.machine_st, self.process_wait());
step_or_fail!(self, self.machine_st.p += 1);

2
src/machine/machine_errors.rs
View File

@@ -44,6 +44,7 @@ pub(crate) enum ValidType {
// PredicateIndicator,
// Variable
TcpListener,
Process,
}
impl ValidType {
@@ -67,6 +68,7 @@ impl ValidType {
// ValidType::PredicateIndicator => atom!("predicate_indicator"),
// ValidType::Variable => atom!("variable")
ValidType::TcpListener => atom!("tcp_listener"),
ValidType::Process => atom!("process"),
}
}
}

3
src/machine/machine_state.rs
View File

@@ -20,11 +20,9 @@ use crate::parser::dashu::Integer;
use indexmap::IndexMap;
use std::collections::BTreeMap;
use std::convert::TryFrom;
use std::fmt;
use std::ops::{Index, IndexMut, Range};
use std::process::Child;
use std::sync::Arc;
pub(crate) type Registers = [HeapCellValue; MAX_ARITY + 1];
@@ -99,7 +97,6 @@ pub struct MachineState {
pub(crate) unify_fn: fn(&mut MachineState),
pub(crate) bind_fn: fn(&mut MachineState, Ref, HeapCellValue),
pub(crate) run_cleaners_fn: fn(&mut Machine) -> bool,
pub(crate) child_processes: BTreeMap<u32, Child>,
}
impl fmt::Debug for MachineState {

2
src/machine/machine_state_impl.rs
View File

@@ -19,7 +19,6 @@ use crate::types::*;
use indexmap::IndexSet;
use std::cmp::Ordering;
use std::collections::BTreeMap;
use std::convert::TryFrom;
impl MachineState {
@@ -68,7 +67,6 @@ impl MachineState {
unify_fn: MachineState::unify,
bind_fn: MachineState::bind,
run_cleaners_fn: |_| false,
child_processes: BTreeMap::new(),
}
}

148
src/machine/system_calls.rs
View File

@@ -56,6 +56,7 @@ use std::net::{SocketAddr, ToSocketAddrs};
use std::net::{TcpListener, TcpStream};
use std::num::NonZeroU32;
use std::process;
use std::process::Child;
use std::process::Stdio;
#[cfg(feature = "http")]
use std::str::FromStr;
@@ -8496,16 +8497,13 @@ impl Machine {
match command.spawn() {
Ok(child) => {
let pid = child.id();
dbg!(pid);
self.machine_st.child_processes.insert(pid, child);
let child_process_alloc: TypedArenaPtr<Child> =
arena_alloc!(child, &mut self.machine_st.arena);
unify!(
self.machine_st,
pid_r,
fixnum_as_cell!(Fixnum::build_with(pid))
typed_arena_ptr_as_cell!(child_process_alloc)
);
Ok(())
@@ -8617,44 +8615,84 @@ impl Machine {
})
}
pub(crate) fn process_id(&mut self) -> CallResult {
fn stub_gen() -> Vec<FunctorElement> {
functor_stub(atom!("process_id"), 2)
}
// Process
let process_r = self.deref_register(1);
// Pid
let pid_r = self.deref_register(2);
let Some(ptr) = process_r.to_untyped_arena_ptr() else {
let err = self.machine_st.type_error(ValidType::Process, process_r);
return Err(self.machine_st.error_form(err, stub_gen()));
};
let process = match_untyped_arena_ptr!(ptr,
(ArenaHeaderTag::ChildProcess, child_process) => {
child_process
}
(ArenaHeaderTag::Dropped, _dropped) => {
let err = self.machine_st.existence_error(ExistenceError::Process(process_r));
return Err(self.machine_st.error_form(err, stub_gen()));
}
_ => {
let err = self.machine_st.type_error(ValidType::Process, process_r);
return Err(self.machine_st.error_form(err, stub_gen()));
}
);
self.machine_st.bind(
pid_r.as_var().unwrap(),
fixnum_as_cell!(Fixnum::build_with(process.id())),
);
Ok(())
}
pub(crate) fn process_wait(&mut self) -> CallResult {
fn stub_gen() -> Vec<FunctorElement> {
functor_stub(atom!("process_wait"), 2)
}
// Pid
let pid_r = self.deref_register(1);
// Process
let process_r = self.deref_register(1);
// Var | Status
let status_r = self.deref_register(2);
// timeout | 0
let timeout_r = self.deref_register(3);
let Some(pid) = pid_r
.to_fixnum()
.and_then(|elem| elem.get_num().try_into().ok())
else {
let err = self
.machine_st
.existence_error(ExistenceError::Process(pid_r));
return Err(self.machine_st.error_form(err, stub_gen()));
};
let Some(child) = self.machine_st.child_processes.get_mut(&pid) else {
let err = self
.machine_st
.existence_error(ExistenceError::Process(pid_r));
let Some(ptr) = process_r.to_untyped_arena_ptr() else {
let err = self.machine_st.type_error(ValidType::Process, process_r);
return Err(self.machine_st.error_form(err, stub_gen()));
};
let mut process = match_untyped_arena_ptr!(ptr,
(ArenaHeaderTag::ChildProcess, child_process) => {
child_process
}
(ArenaHeaderTag::Dropped, _dropped) => {
let err = self.machine_st.existence_error(ExistenceError::Process(process_r));
return Err(self.machine_st.error_form(err, stub_gen()));
}
_ => {
let err = self.machine_st.type_error(ValidType::Process, process_r);
return Err(self.machine_st.error_form(err, stub_gen()));
}
);
let status = if let Some(atom) = timeout_r.to_atom() {
match atom {
atom!("infinite") => child.wait().map(Some),
atom!("infinite") => process.wait().map(Some),
_ => {
panic!("Invalid Timeout value")
}
}
} else if let Some(timeout) = timeout_r.to_fixnum() {
if timeout.get_num() == 0 {
child.try_wait()
process.try_wait()
} else {
panic!("Invalid Timeout value")
}
@@ -8728,23 +8766,28 @@ impl Machine {
}
// Pid
let pid_r = self.deref_register(1);
let Some(pid) = pid_r
.to_fixnum()
.and_then(|elem| elem.get_num().try_into().ok())
else {
let err = self
.machine_st
.existence_error(ExistenceError::Process(pid_r));
let process_r = self.deref_register(1);
let Some(ptr) = process_r.to_untyped_arena_ptr() else {
let err = self.machine_st.type_error(ValidType::Process, process_r);
return Err(self.machine_st.error_form(err, stub_gen()));
};
let Some(child) = self.machine_st.child_processes.get_mut(&pid) else {
let err = self
.machine_st
.existence_error(ExistenceError::Process(pid_r));
return Err(self.machine_st.error_form(err, stub_gen()));
};
if child.kill().is_err() {
let mut process = match_untyped_arena_ptr!(ptr,
(ArenaHeaderTag::ChildProcess, child_process) => {
child_process
}
(ArenaHeaderTag::Dropped, _dropped) => {
let err = self.machine_st.existence_error(ExistenceError::Process(process_r));
return Err(self.machine_st.error_form(err, stub_gen()));
}
_ => {
let err = self.machine_st.type_error(ValidType::Process, process_r);
return Err(self.machine_st.error_form(err, stub_gen()));
}
);
if process.kill().is_err() {
let perm_error =
self.machine_st
.permission_error(Permission::Modify, atom!("process"), stub_gen());
@@ -8758,18 +8801,23 @@ impl Machine {
functor_stub(atom!("process_release"), 1)
}
let pid_r = self.deref_register(1);
let Some(pid) = pid_r
.to_fixnum()
.and_then(|elem| elem.get_num().try_into().ok())
else {
let err = self
.machine_st
.existence_error(ExistenceError::Process(pid_r));
return Err(self.machine_st.error_form(err, stub_gen()));
};
self.machine_st.child_processes.remove(&pid);
Ok(())
let process = self.deref_register(1);
if let Some(ptr) = process.to_untyped_arena_ptr() {
match_untyped_arena_ptr!(ptr,
(ArenaHeaderTag::ChildProcess, child_process) => {
child_process.drop_payload();
return Ok(());
}
_ => {
}
);
}
let err = self.machine_st.type_error(ValidType::Process, process);
Err(self.machine_st.error_form(err, stub_gen()))
}
#[inline(always)]

6
src/macros.rs
View File

@@ -218,6 +218,12 @@ macro_rules! match_untyped_arena_ptr_pat_body {
#[allow(unused_braces)]
$code
}};
($ptr:ident, ChildProcess, $listener:ident, $code:expr) => {{
#[allow(unused_mut)]
let mut $listener = unsafe { $ptr.as_typed_ptr::<std::process::Child>() };
#[allow(unused_braces)]
$code
}};
($ptr:ident, $($tags:tt)|+, $s:ident, $code:expr) => {{
let $s = Stream::from_tag($ptr.get_tag(), $ptr);
#[allow(unused_braces)]

4
tests/scryer/cli/unix/process.md Normal file
View File

@@ -0,0 +1,4 @@
```trycmd
$ scryer-prolog -f --no-add-history -g 'use_module(library(process)), process_create("false", [], [process(P)]), process_wait(P, exit(1)), halt'
```

4
tests/scryer/cli/windows/process.md Normal file
View File

@@ -0,0 +1,4 @@
```trycmd
$ scryer-prolog -f --no-add-history -g 'use_module(library(process)), process_create("cmd", ["/C", "exit", "1"], [process(P)]), process_wait(P, exit(1)), halt'
```

16
tests/scryer/main.rs
View File

@@ -19,9 +19,19 @@ mod src_tests;
ignore = "miri isolation, unsupported operation: can't call foreign function"
)]
fn cli_tests() {
trycmd::TestCases::new()
let cases = trycmd::TestCases::new();
cases
.default_bin_name("scryer-prolog")
.case("tests/scryer/cli/issues/*.toml")
.case("tests/scryer/cli/src_tests/*.toml")
.case("tests/scryer/cli/src_tests/*.md");
.case("tests/scryer/cli/src_tests/*.toml");
#[cfg(windows)]
{
cases.case("tests/scryer/cli/windows/*.md");
}
#[cfg(unix)]
{
cases.case("tests/scryer/cli/unix/*.md");
}
}