ShuriZma
/
FPPS4
mirror of https://github.com/red-prig/fpPS4.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

+

This commit is contained in:
Pavel 2023-05-26 17:43:47 +03:00
parent fdec9cd122
commit 943a56ca5d
25 changed files with 5269 additions and 246 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
rtl/ntapi.pas
View File

@ -51,6 +51,7 @@ const
NT_INFINITE=$8000000000000000;
//ThreadInformationClass
ThreadBasicInformation = 0;
ThreadTimes = 1;
ThreadPriority = 2;
@ -70,13 +71,24 @@ const
ThreadIsIoPending = 16;
ThreadHideFromDebugger = 17;
//ProcessInformationClass
ProcessBasicInformation=0;
ProcessQuotaLimits =1;
ProcessIoCounters =2;
ProcessVmCounters =3;
ProcessTimes =4;
ProcessPriorityClass =18;
ProcessAffinityMask =21;
//ntapi PriorityClass
PROCESS_PRIORITY_CLASS_UNKNOWN =0;
PROCESS_PRIORITY_CLASS_IDLE =1;
PROCESS_PRIORITY_CLASS_NORMAL =2;
PROCESS_PRIORITY_CLASS_HIGH =3;
PROCESS_PRIORITY_CLASS_REALTIME =4;
PROCESS_PRIORITY_CLASS_BELOW_NORMAL=5;
PROCESS_PRIORITY_CLASS_ABOVE_NORMAL=6;
//FileInformationClass
FileBasicInformation = 4;
FileStandardInformation = 5;
@ -418,6 +430,12 @@ type
InheritedFromUPI:QWORD;
end;
PPROCESS_PRIORITY_CLASS=^PROCESS_PRIORITY_CLASS;
PROCESS_PRIORITY_CLASS=packed record
Foreground :Boolean;
PriorityClass:Byte;
end;
PKERNEL_USER_TIMES=^KERNEL_USER_TIMES;
KERNEL_USER_TIMES=packed record
CreateTime:LARGE_INTEGER;

11
sys/kern/kern_cpuset.pas
View File

@ -25,7 +25,8 @@ uses
systm,
kern_thr,
kern_thread,
vm_machdep;
md_thread,
md_proc;
function sys_cpuset_getaffinity(level,which:Integer;id,cpusetsize:QWORD;mask:p_cpuset_t):Integer;
var
@ -39,7 +40,7 @@ begin
Case which of
CPU_WHICH_TID:
begin
if (int64(id)=-1) then
if (Integer(id)=-1) then
begin
td:=curkthread;
thread_inc_ref(td);
@ -56,7 +57,7 @@ begin
end;
CPU_WHICH_PID:
begin
if (int64(id)=-1) or (id=g_pid) then
if (Integer(id)=-1) or (id=g_pid) then
begin
Result:=cpuset_getproc(old);
if (Result<>0) then Exit(ESRCH);
@ -87,7 +88,7 @@ begin
Case which of
CPU_WHICH_TID:
begin
if (int64(id)=-1) then
if (Integer(id)=-1) then
begin
td:=curkthread;
thread_inc_ref(td);
@ -106,7 +107,7 @@ begin
CPU_WHICH_PID:
begin
begin
if (int64(id)=-1) or (id=g_pid) then
if (Integer(id)=-1) or (id=g_pid) then
begin
Result:=cpuset_setproc(new);
if (Result<>0) then Result:=ESRCH;

188
sys/kern/kern_exit.pas Normal file
View File

@ -0,0 +1,188 @@
unit kern_exit;
{$mode ObjFPC}{$H+}
{$CALLING SysV_ABI_CDecl}
interface
uses
kern_resource;
const
WCOREFLAG=&0200;
_WSTOPPED=&0177; { _WSTATUS if process is stopped }
{
* Option bits for the third argument of wait4. WNOHANG causes the
* wait to not hang if there are no stopped or terminated processes, rather
* returning an error indication in this case (pid==0). WUNTRACED
* indicates that the caller should receive status about untraced children
* which stop due to signals. If children are stopped and a wait without
* this option is done, it is as though they were still running... nothing
* about them is returned. WNOWAIT only request information about zombie,
* leaving the proc around, available for later waits.
}
WNOHANG =1; { Don't hang in wait. }
WUNTRACED =2; { Tell about stopped, untraced children. }
WSTOPPED =WUNTRACED; { SUS compatibility }
WCONTINUED=4; { Report a job control continued process. }
WNOWAIT =8; { Poll only. Don't delete the proc entry. }
WEXITED =16; { Wait for exited processes. }
WTRAPPED =32; { Wait for a process to hit a trap or a breakpoint. }
WLINUXCLONE=$80000000; { Wait for kthread spawned from linux_clone. }
{
* Tokens for special values of the "pid" parameter to wait4.
* Extended struct __wrusage to collect rusage for both the target
* process and its children within one wait6() call.
}
WAIT_ANY =(-1); { any process }
WAIT_MYPGRP=0; { any process in my process group }
type
_W_INT=Integer;
function _WSTATUS(x:Integer):Integer; inline;
function WIFSTOPPED(x:Integer):Boolean; inline;
function WSTOPSIG(x:Integer):Integer; inline;
function WIFSIGNALED(x:Integer):Boolean; inline;
function WTERMSIG(x:Integer):Integer; inline;
function WIFEXITED(x:Integer):Boolean; inline;
function WEXITSTATUS(x:Integer):Integer; inline;
function WIFCONTINUED(x:Integer):Boolean; inline; { 0x13=SIGCONT }
function WCOREDUMP(x:Integer):Boolean; inline;
function W_STOPCODE(sig:Integer):Integer; inline;
function W_EXITCODE(ret,sig:Integer):Integer; inline;
procedure exit1(rv:Integer);
procedure sys_sys_exit(rval:Integer);
function sys_wait4(pid:Integer;status:PInteger;options:Integer;rusage:p_rusage):Integer;
implementation
uses
errno,
systm;
function _WSTATUS(x:Integer):Integer; inline;
begin
Result:=(_W_INT(x) and &0177);
end;
function WIFSTOPPED(x:Integer):Boolean; inline;
begin
Result:=(_WSTATUS(x)=_WSTOPPED);
end;
function WSTOPSIG(x:Integer):Integer; inline;
begin
Result:=(_W_INT(x) shr 8) ;
end;
function WIFSIGNALED(x:Integer):Boolean; inline;
begin
Result:=(_WSTATUS(x)<>_WSTOPPED) and (_WSTATUS(x)<>0);
end;
function WTERMSIG(x:Integer):Integer; inline;
begin
Result:=(_WSTATUS(x));
end;
function WIFEXITED(x:Integer):Boolean; inline;
begin
Result:=(_WSTATUS(x)=0);
end;
function WEXITSTATUS(x:Integer):Integer; inline;
begin
Result:=(_W_INT(x) shr 8);
end;
function WIFCONTINUED(x:Integer):Boolean; inline; { 0x13=SIGCONT }
begin
Result:=(x=$13);
end;
function WCOREDUMP(x:Integer):Boolean; inline;
begin
Result:=(_W_INT(x) and WCOREFLAG)<>0;
end;
function W_STOPCODE(sig:Integer):Integer; inline;
begin
Result:=(sig shl 8) or _WSTOPPED;
end;
function W_EXITCODE(ret,sig:Integer):Integer; inline;
begin
Result:=(ret shl 8) or sig;
end;
procedure exit1(rv:Integer);
begin
Halt(rv);
end;
procedure sys_sys_exit(rval:Integer);
begin
exit1(W_EXITCODE(rval, 0));
// NOTREACHED
end;
function kern_wait(pid:Integer;status:PInteger;options:Integer;rusage:p_rusage):Integer;
begin
options:=options or WEXITED or WTRAPPED;
{ If we don't know the option, just return. }
if ((options and (not (WUNTRACED or WNOHANG or WCONTINUED or WNOWAIT or
WEXITED or WTRAPPED or WLINUXCLONE)))<>0) then
begin
Exit(EINVAL);
end;
if ((options and (WEXITED or WUNTRACED or WCONTINUED or WTRAPPED))=0) then
begin
{
* We will be unable to find any matching processes,
* because there are no known events to look for.
* Prefer to Exiterror instead of blocking
* indefinitely.
}
Exit(EINVAL);
end;
Exit(ECHILD);
end;
{
* The dirty work is handled by kern_wait().
}
function sys_wait4(pid:Integer;status:PInteger;options:Integer;rusage:p_rusage):Integer;
var
ru:t_rusage;
rup:p_rusage;
error,_status:Integer;
begin
if (rusage<>nil) then
rup:=@ru
else
rup:=nil;
error:=kern_wait(pid, @_status, options, rup);
if (status<>nil) and (error=0) then
error:=copyout(@_status, status, sizeof(_status));
if (rusage<>nil) and (error=0) then
error:=copyout(@ru, rusage, sizeof(t_rusage));
Exit(error);
end;
end.

488
sys/kern/kern_prot.pas Normal file
View File

@ -0,0 +1,488 @@
unit kern_prot;
{$mode ObjFPC}{$H+}
{$CALLING SysV_ABI_CDecl}
interface
const
MAXLOGNAME =17; { max login name length (incl. NUL) }
function sys_getpid():Integer;
function sys_getppid():Integer;
function sys_getpgrp():Integer;
function sys_getpgid():Integer;
function sys_getsid():Integer;
function sys_getuid():Integer;
function sys_geteuid():Integer;
function sys_getgid():Integer;
function sys_getegid():Integer;
function sys_getgroups(gidsetsize:DWORD;gidset:PInteger):Integer;
function sys_setsid():Integer;
function sys_setpgid(pid,pgid:Integer):Integer;
function sys_setuid(uid:Integer):Integer;
function sys_seteuid(euid:Integer):Integer;
function sys_setgid(gid:Integer):Integer;
function sys_setegid(egid:Integer):Integer;
function sys_setgroups(gidsetsize:DWORD;gidset:PInteger):Integer;
function sys_setreuid(ruid,euid:Integer):Integer;
function sys_setregid(rgid,egid:Integer):Integer;
function sys_setresuid(ruid,euid,suid:Integer):Integer;
function sys_setresgid(rgid,egid,sgid:Integer):Integer;
function sys_getresuid(ruid,euid,suid:PInteger):Integer;
function sys_getresgid(rgid,egid,sgid:PInteger):Integer;
function sys_issetugid():Integer;
function sys_getlogin(namebuf:PChar;namelen:DWORD):Integer;
function sys_setlogin(namebuf:PChar):Integer;
function p_cansignal(signum:Integer):Integer;
implementation
uses
errno,
systm,
signal,
kern_thr,
md_proc;
{
* System calls related to processes and protection
}
function sys_getpid():Integer;
var
td:p_kthread;
begin
td:=curkthread;
if (td=nil) then Exit(-1);
td^.td_retval[0]:=g_pid;
Exit(0);
end;
function sys_getppid():Integer;
var
td:p_kthread;
begin
td:=curkthread;
if (td=nil) then Exit(-1);
td^.td_retval[0]:=1; //psevodo parent id
Exit(0);
end;
{
* Get process group ID; note that POSIX getpgrp takes no parameter.
}
function sys_getpgrp():Integer;
var
td:p_kthread;
begin
td:=curkthread;
if (td=nil) then Exit(-1);
td^.td_retval[0]:=0; //psevodo group id
Exit(0);
end;
{ Get an arbitary pid's process group id }
function sys_getpgid():Integer;
var
td:p_kthread;
begin
td:=curkthread;
if (td=nil) then Exit(-1);
td^.td_retval[0]:=0; //psevodo group id
Exit(0);
end;
{
* Get an arbitary pid's session id.
}
function sys_getsid():Integer;
var
td:p_kthread;
begin
td:=curkthread;
if (td=nil) then Exit(-1);
td^.td_retval[0]:=0; //psevodo session id
Exit(0);
end;
function sys_getuid():Integer;
var
td:p_kthread;
begin
td:=curkthread;
if (td=nil) then Exit(-1);
td^.td_retval[0]:=0; //psevodo user id
Exit(0);
end;
function sys_geteuid():Integer;
var
td:p_kthread;
begin
td:=curkthread;
if (td=nil) then Exit(-1);
td^.td_retval[0]:=0; //psevodo user id
Exit(0);
end;
function sys_getgid():Integer;
var
td:p_kthread;
begin
td:=curkthread;
if (td=nil) then Exit(-1);
td^.td_retval[0]:=0; //psevodo group id
Exit(0);
end;
{
* Get effective group ID. The 'egid' is groups[0], and could be obtained
* via getgroups. This syscall exists because it is somewhat painful to do
* correctly in a library function.
}
function sys_getegid():Integer;
var
td:p_kthread;
begin
td:=curkthread;
if (td=nil) then Exit(-1);
td^.td_retval[0]:=0; //psevodo group id
Exit(0);
end;
function sys_getgroups(gidsetsize:DWORD;gidset:PInteger):Integer;
const
cr_ngroups=1;
var
td:p_kthread;
ngrp:Integer;
groups:array[0..0] of Integer;
begin
td:=curkthread;
if (td=nil) then Exit(-1);
if (gidsetsize < cr_ngroups) then
begin
if (gidsetsize=0) then
ngrp:=0
else
Exit(EINVAL);
end else
ngrp:=cr_ngroups;
groups[0]:=0;
if (gidsetsize > 0) then
Result:=copyout(@groups, gidset, ngrp * sizeof(Integer));
if (Result=0) then
td^.td_retval[0]:=ngrp;
end;
function sys_setsid():Integer;
begin
Exit(EPERM);
end;
{
* set process group (setpgid/old setpgrp)
*
* caller does setpgid(targpid, targpgid)
*
* pid must be caller or child of caller (ESRCH)
* if a child
* pid must be in same session (EPERM)
* pid can't have done an exec (EACCES)
* if pgid<>pid
* there must exist some pid in same session having pgid (EPERM)
* pid must not be session leader (EPERM)
}
function sys_setpgid(pid,pgid:Integer):Integer;
begin
if (pid<>0) and (pid<>g_pid) then
begin
Exit(ESRCH);
end;
Exit(EPERM);
end;
{
* Use the clause in B.4.2.2 that allows setuid/setgid to be 4.2/4.3BSD
* compatible. It says that setting the uid/gid to euid/egid is a special
* case of 'appropriate privilege'. Once the rules are expanded out, this
* basically means that setuid(nnn) sets all three id's, in all permitted
* cases unless _POSIX_SAVED_IDS is enabled. In that case, setuid(getuid())
* does not set the saved id - this is dangerous for traditional BSD
* programs. For this reason, we *really* do not want to set
* _POSIX_SAVED_IDS and do not want to clear POSIX_APPENDIX_B_4_2_2.
}
function sys_setuid(uid:Integer):Integer;
begin
Result:=0;
if (uid<>0) then //not psevodo user id
begin
Exit(EPERM);
end;
end;
function sys_seteuid(euid:Integer):Integer;
begin
Result:=0;
if (euid<>0) then //not psevodo user id
begin
Exit(EPERM);
end;
end;
function sys_setgid(gid:Integer):Integer;
begin
Result:=0;
if (gid<>0) then //not group user id
begin
Exit(EPERM);
end;
end;
function sys_setegid(egid:Integer):Integer;
begin
Result:=0;
if (egid<>0) then //not group user id
begin
Exit(EPERM);
end;
end;
function sys_setgroups(gidsetsize:DWORD;gidset:PInteger):Integer;
const
ngroups_max=1023;
var
groups:array[0..0] of Integer;
begin
Result:=0;
if (gidsetsize > ngroups_max + 1) then
Exit(EINVAL);
Result:=copyin(gidset, @groups, 1 * sizeof(Integer));
if (Result<>0) then Exit;
if (gidsetsize<>1) then Exit(EPERM);
if (groups[0]<>0) then //not group user id
begin
Exit(EPERM);
end;
end;
function sys_setreuid(ruid,euid:Integer):Integer;
begin
Result:=0;
if (ruid<>0) and (ruid<>-1) then //not psevodo user id
begin
Exit(EPERM);
end;
if (euid<>0) and (euid<>-1) then //not psevodo user id
begin
Exit(EPERM);
end;
end;
function sys_setregid(rgid,egid:Integer):Integer;
begin
Result:=0;
if (rgid<>0) and (rgid<>-1) then //not psevodo group id
begin
Exit(EPERM);
end;
if (egid<>0) and (egid<>-1) then //not psevodo group id
begin
Exit(EPERM);
end;
end;
{
* setresuid(ruid, euid, suid) is like setreuid except control over the saved
* uid is explicit.
}
function sys_setresuid(ruid,euid,suid:Integer):Integer;
begin
Result:=0;
if (ruid<>0) and (ruid<>-1) then //not psevodo user id
begin
Exit(EPERM);
end;
if (euid<>0) and (euid<>-1) then //not psevodo user id
begin
Exit(EPERM);
end;
if (suid<>0) and (suid<>-1) then //not psevodo session id
begin
Exit(EPERM);
end;
end;
{
* setresgid(rgid, egid, sgid) is like setregid except control over the saved
* gid is explicit.
}
function sys_setresgid(rgid,egid,sgid:Integer):Integer;
begin
Result:=0;
if (rgid<>0) and (rgid<>-1) then //not psevodo group id
begin
Exit(EPERM);
end;
if (egid<>0) and (egid<>-1) then //not psevodo group id
begin
Exit(EPERM);
end;
if (sgid<>0) and (sgid<>-1) then //not psevodo group id
begin
Exit(EPERM);
end;
end;
function sys_getresuid(ruid,euid,suid:PInteger):Integer;
var
cr_uid:Integer;
error1,error2,error3:Integer;
begin
cr_uid:=0; //psevodo user id
error1:=0;
error2:=0;
error3:=0;
if (ruid<>nil) then
error1:=copyout(@cr_uid, ruid, sizeof(Integer));
if (euid<>nil) then
error2:=copyout(@cr_uid, euid, sizeof(Integer));
if (suid<>nil) then
error3:=copyout(@cr_uid, suid, sizeof(Integer));
if (error1<>0) then
begin
Exit(error1);
end else
if (error2<>0) then
begin
Exit(error2);
end else
begin
Exit(error3);
end;
end;
function sys_getresgid(rgid,egid,sgid:PInteger):Integer;
var
cr_gid:Integer;
error1,error2,error3:Integer;
begin
cr_gid:=0; //psevodo group id
error1:=0;
error2:=0;
error3:=0;
if (rgid<>nil) then
error1:=copyout(@cr_gid, rgid, sizeof(Integer));
if (egid<>nil) then
error2:=copyout(@cr_gid, egid, sizeof(Integer));
if (sgid<>nil) then
error3:=copyout(@cr_gid, sgid, sizeof(Integer));
if (error1<>0) then
begin
Exit(error1);
end else
if (error2<>0) then
begin
Exit(error2);
end else
begin
Exit(error3);
end;
end;
function sys_issetugid():Integer;
begin
Exit(0);
end;
{
* Get login name, if available.
}
function sys_getlogin(namebuf:PChar;namelen:DWORD):Integer;
var
login:array[0..MAXLOGNAME-1] of AnsiChar;
len:ptrint;
begin
if (namelen > MAXLOGNAME) then
namelen:=MAXLOGNAME;
login:='user';
len:=strlen(@login);
if (len > namelen) then
Exit(ERANGE);
Exit(copyout(@login, namebuf, len));
end;
{
* Set login name.
}
function sys_setlogin(namebuf:PChar):Integer;
begin
//error:=priv_check(td, PRIV_PROC_SETLOGIN);
Exit(EPERM);
end;
{-
* Determine whether td may deliver the specified signal to p.
* Returns: 0 for permitted, an errno value otherwise
* Locks: Sufficient locks to protect various components of td and p
* must be held. td must be curthread, and a lock must be
* held for p.
* References: td and p must be valid for the lifetime of the call
}
function p_cansignal(signum:Integer):Integer;
begin
if (curkthread=nil) then Exit(-1);
{
* UNIX signalling semantics require that processes in the same
* session always be able to deliver SIGCONT to one another,
* overriding the remaining protections.
}
{ XXX: This will require an additional lock of some sort. }
if (signum=SIGCONT) {and (td^.td_proc^.p_session=p^.p_session)} then
Exit(0);
{
* Some compat layers use SIGTHR and higher signals for
* communication between different kernel threads of the same
* process, so that they expect that it's always possible to
* deliver them, even for suid applications where cr_cansignal() can
* deny such ability for security consideration. It should be
* pretty safe to do since the only way to create two processes
* with the same p_leader is via rfork(2).
}
if (signum >= SIGTHR) and
(signum < SIGTHR + 4) then
Exit(0);
//Exit(cr_cansignal(td^.td_ucred, p, signum));
Exit(0);
end;
end.

226
sys/kern/kern_resource.pas Normal file
View File

@ -0,0 +1,226 @@
unit kern_resource;
{$mode ObjFPC}{$H+}
{$CALLING SysV_ABI_CDecl}
interface
uses
time,
vmparam,
vfile;
const
RLIMIT_CPU = 0; // maximum cpu time in seconds
RLIMIT_FSIZE = 1; // maximum file size
RLIMIT_DATA = 2; // data size
RLIMIT_STACK = 3; // stack size
RLIMIT_CORE = 4; // core file size
RLIMIT_RSS = 5; // resident set size
RLIMIT_MEMLOCK= 6; // locked-in-memory address space
RLIMIT_NPROC = 7; // number of processes
RLIMIT_NOFILE = 8; // number of open files
RLIMIT_SBSIZE = 9; // maximum size of all socket buffers
RLIMIT_VMEM =10; // virtual process size (incl. mmap)
RLIMIT_AS =RLIMIT_VMEM; // standard name for RLIMIT_VMEM
RLIMIT_NPTS =11; // pseudo-terminals
RLIMIT_SWAP =12; // swap used
function lim_max(which:Integer):QWORD;
function lim_cur(which:Integer):QWORD;
const
RUSAGE_SELF = 0;
RUSAGE_CHILDREN=-1;
RUSAGE_THREAD = 1;
type
p_rusage=^t_rusage;
t_rusage=packed record
ru_utime :timeval; // user time used
ru_stime :timeval; // system time used
ru_maxrss :DWORD; // max resident set size
ru_ixrss :DWORD; // integral shared memory size *
ru_idrss :DWORD; // integral unshared data
ru_isrss :DWORD; // integral unshared stack
ru_minflt :DWORD; // page reclaims
ru_majflt :DWORD; // page faults
ru_nswap :DWORD; // swaps
ru_inblock :DWORD; // block input operations
ru_oublock :DWORD; // block output operations
ru_msgsnd :DWORD; // messages sent
ru_msgrcv :DWORD; // messages received
ru_nsignals:DWORD; // signals received
ru_nvcsw :DWORD; // voluntary context switches
ru_nivcsw :DWORD; // involuntary
end;
const
//Process priority specifications to get/setpriority.
PRIO_MIN=-20;
PRIO_MAX= 20;
PRIO_PROCESS=0;
PRIO_PGRP =1;
PRIO_USER =2;
function sys_getpriority(which,who:Integer):Integer;
function sys_setpriority(which,who,prio:Integer):Integer;
implementation
uses
errno,
kern_thr,
md_proc;
function lim_max(which:Integer):QWORD;
begin
Result:=0;
Case which of
RLIMIT_DATA :Result:=MAXDSIZ;
RLIMIT_STACK :Result:=MAXSSIZ;
RLIMIT_MEMLOCK:Result:=pageablemem;
RLIMIT_VMEM :Result:=pageablemem;
RLIMIT_NOFILE :Result:=maxfilesperproc;
else;
end;
end;
function lim_cur(which:Integer):QWORD;
begin
Result:=0;
Case which of
RLIMIT_DATA :Result:=MAXDSIZ;
RLIMIT_STACK :Result:=MAXSSIZ;
RLIMIT_MEMLOCK:Result:=pageablemem;
RLIMIT_VMEM :Result:=pageablemem;
RLIMIT_NOFILE :Result:=maxfilesperproc;
else;
end;
end;
function cur_proc_get_nice():Integer; inline;
begin
Result:=get_proc_prio;
end;
function cur_proc_donice(n:Integer):Integer;
begin
if (n > PRIO_MAX) then n:=PRIO_MAX;
if (n < PRIO_MIN) then n:=PRIO_MIN;
//if (n < cur_proc_get_nice) and (priv_check(td, PRIV_SCHED_SETPRIORITY) <> 0) then
// Exit(EACCES);
Result:=set_proc_prio(n);
if (Result<>0) then Result:=EPERM;
end;
{
* Resource controls and accounting.
}
function sys_getpriority(which,who:Integer):Integer;
var
td:p_kthread;
error,low:Integer;
begin
td:=curkthread;
if (td=nil) then Exit(-1);
error:=0;
low:=PRIO_MAX+1;
case (which) of
PRIO_PROCESS:
begin
if (who=0) or (who=g_pid) then
begin
low:=cur_proc_get_nice;
end;
end;
PRIO_PGRP:
begin
if (who=0) then
begin
low:=cur_proc_get_nice;
end;
end;
PRIO_USER:
begin
if (who=0) or (who=g_pid) then
begin
low:=cur_proc_get_nice;
end;
end;
else
error:=EINVAL;
end;
if (low=PRIO_MAX+1) and (error=0) then
error:=ESRCH;
td^.td_retval[0]:=low;
Exit(error);
end;
function sys_setpriority(which,who,prio:Integer):Integer;
var
found,error:Integer;
begin
found:=0;
error:=0;
case (which) of
PRIO_PROCESS:
begin
if (who=0) or (who=g_pid) then
begin
PROC_LOCK();
error:=cur_proc_donice(prio);
PROC_UNLOCK();
Inc(found);
end;
end;
PRIO_PGRP:
begin
if (who=0) then
begin
PROC_LOCK();
error:=cur_proc_donice(prio);
PROC_UNLOCK();
Inc(found);
end;
end;
PRIO_USER:
begin
if (who=0) or (who=g_pid) then
begin
PROC_LOCK();
error:=cur_proc_donice(prio);
PROC_UNLOCK();
Inc(found);
end;
end;
else
error:=EINVAL;
end;
if (found=0) and (error=0) then
error:=ESRCH;
Exit(error);
end;
end.

2
sys/kern/kern_rtprio.pas
View File

@ -21,7 +21,7 @@ uses
errno,
kern_thread,
sched_ule,
vm_machdep;
md_proc;
function rtp_to_pri(rtp:p_rtprio;td:p_kthread):Integer;
var

110
sys/kern/kern_sig.pas
View File

@ -76,6 +76,8 @@ Function sys_sigsuspend(sigmask:p_sigset_t):Integer;
Function sys_sigaltstack(ss:p_stack_t;oss:p_stack_t):Integer;
function sys_kill(pid,signum:Integer):Integer;
Function sigonstack(sp:size_t):Integer;
procedure sigqueue_init(list:p_sigqueue);
procedure tdsigcleanup(td:p_kthread);
@ -112,7 +114,11 @@ uses
kern_mtx,
kern_time,
kern_thread,
kern_exit,
kern_prot,
vm_machdep,
md_thread,
md_proc,
machdep,
sched_ule,
subr_sleepqueue;
@ -1115,6 +1121,103 @@ begin
end;
end;
function pksignal(sig:Integer;ksi:p_ksiginfo):Integer; forward;
{
* Common code for kill process group/broadcast kill.
* cp is calling process.
}
function killpg1(sig,pgid,all:Integer;ksi:p_ksiginfo):Integer;
var
err:Integer;
begin
Result:=ESRCH;
if (all<>0) then
begin
//broadcast
PROC_LOCK;
err:=p_cansignal(sig);
if (err=0) then
begin
if (sig<>0) then pksignal(sig, ksi);
Result:=err;
end else
if (Result=ESRCH) then
begin
Result:=err;
end;
PROC_UNLOCK;
end else
begin
if (pgid=0) then
begin
//zero pgid means send to my process group.
end else
begin
Exit(ESRCH);
end;
PROC_LOCK;
err:=p_cansignal(sig);
if (err=0) then
begin
if (sig<>0) then pksignal(sig, ksi);
Result:=err;
end else
if (Result=ESRCH) then
begin
Result:=err;
end;
PROC_UNLOCK;
end;
end;
function sys_kill(pid,signum:Integer):Integer;
var
ksi:ksiginfo_t;
error:Integer;
begin
if (signum > _SIG_MAXSIG) then
Exit(EINVAL);
ksiginfo_init(@ksi);
ksi.ksi_info.si_signo:=signum;
ksi.ksi_info.si_code:=SI_USER;
ksi.ksi_info.si_pid :=pid;
if (pid > 0) then
begin
{ kill single process }
if (pid<>g_pid) then Exit(ESRCH);
PROC_LOCK;
error:=p_cansignal(signum);
if (error=0) and (signum<>0) then
pksignal(signum, @ksi);
PROC_UNLOCK;
Exit(error);
end;
case pid of
-1: { broadcast signal }
Exit(killpg1(signum, 0, 1, @ksi));
0: { signal own process group }
Exit(killpg1(signum, 0, 0, @ksi));
else { negative explicit process group }
Exit(killpg1(signum, -pid, 0, @ksi));
end;
{ NOTREACHED }
end;
procedure postsig_done(sig:Integer;td:p_kthread);
var
mask:sigset_t;
@ -1585,14 +1688,9 @@ begin
Result:=1;
end;
function W_EXITCODE(ret,sig:Integer):Integer; inline;
begin
Result:=(ret shl 8) or sig;
end;
procedure sigexit(td:p_kthread;sig:Integer);
begin
Halt(W_EXITCODE(0,sig));
exit1(W_EXITCODE(0,sig));
// NOTREACHED
end;

12
sys/kern/kern_synch.pas
View File

@ -47,6 +47,8 @@ procedure wakeup_one(ident:Pointer);
procedure maybe_yield();
procedure kern_yield(prio:Integer);
function sys_yield():Integer;
function sys_sched_yield():Integer;
function sys_cpumode_yield():Integer;
implementation
@ -169,5 +171,15 @@ begin
Exit(0);
end;
function sys_sched_yield():Integer;
begin
Result:=sys_yield;
end;
function sys_cpumode_yield():Integer;
begin
Result:=sys_yield;
end;
end.

10
sys/kern/kern_thr.pas
View File

@ -107,6 +107,8 @@ type
iflag :Integer; //0x710
end;
t_td_name=array[0..31] of AnsiChar;
p_kthread=^kthread;
kthread=record
td_umtxq :Pointer; //p_umtx_q
@ -128,7 +130,7 @@ type
td_base_user_pri:Word;
td_lend_user_pri:Word;
td_user_pri :Word;
td_name :array[0..31] of AnsiChar;
td_name :t_td_name;
//
td_cpuset :Ptruint;
td_sigmask :sigset_t;
@ -164,8 +166,8 @@ type
stack_size:Ptruint;
tls_base :Pointer;
tls_size :Ptruint;
child_tid :PQWORD;
parent_tid:PQWORD;
child_tid :PDWORD;
parent_tid:PDWORD;
flags :Integer;
align :Integer;
rtp :Pointer;
@ -388,7 +390,7 @@ var
td:p_kthread;
begin
td:=curkthread;
if (td=nil) then Exit;
if (td=nil) then Exit(0);
Result:=(not flags) or (td^.td_pflags and flags);
td^.td_pflags:=td^.td_pflags or flags;
end;

81
sys/kern/kern_thread.pas
View File

@ -6,6 +6,7 @@ unit kern_thread;
interface
uses
sysutils,
mqueue,
kern_thr,
ntapi,
@ -14,7 +15,6 @@ uses
signal,
signalvar,
time,
kern_time,
rtprio,
kern_rtprio,
hamt;
@ -23,12 +23,13 @@ function thread_alloc:p_kthread;
procedure thread_free(td:p_kthread);
function sys_thr_new(_param:p_thr_param;_size:Integer):Integer;
function sys_thr_self(id:PQWORD):Integer;
function sys_thr_self(id:PDWORD):Integer;
procedure sys_thr_exit(state:PQWORD);
function sys_thr_kill(id:QWORD;sig:Integer):Integer;
function sys_thr_kill(id:DWORD;sig:Integer):Integer;
function sys_thr_suspend(timeout:ptimespec):Integer;
function sys_thr_wake(id:QWORD):Integer;
function sys_thr_set_name(id:QWORD;pname:PChar):Integer;
function sys_thr_wake(id:DWORD):Integer;
function sys_thr_set_name(id:DWORD;pname:PChar):Integer;
function sys_thr_get_name(id:DWORD;pname:PChar):Integer;
function sys_amd64_set_fsbase(base:Pointer):Integer;
@ -69,6 +70,7 @@ uses
errno,
systm,
vm_machdep,
md_thread,
kern_rwlock,
kern_mtx,
kern_umtx,
@ -297,8 +299,8 @@ function create_thread(td :p_kthread; //calling thread
stack_base:Pointer;
stack_size:QWORD;
tls_base :Pointer;
child_tid :PQWORD;
parent_tid:PQWORD;
child_tid :PDWORD;
parent_tid:PDWORD;
rtp :p_rtprio;
name :PChar
):Integer;
@ -401,13 +403,13 @@ begin
if (child_tid<>nil) then
begin
n:=suword64(child_tid^,newtd^.td_tid);
n:=suword32(child_tid^,newtd^.td_tid);
if (n<>0) then Goto _term;
end;
if (parent_tid<>nil) then
begin
n:=suword64(parent_tid^,newtd^.td_tid);
n:=suword32(parent_tid^,newtd^.td_tid);
if (n<>0) then Goto _term;
end;
@ -420,7 +422,7 @@ begin
if (name<>nil) then
begin
Move(name^,newtd^.td_name,SizeOf(newtd^.td_name));
Move(name^,newtd^.td_name,SizeOf(t_td_name));
end;
SetThreadDebugName(newtd^.td_handle,'ps4:'+newtd^.td_name);
@ -450,7 +452,7 @@ function kern_thr_new(td:p_kthread;param:p_thr_param):Integer;
var
rtp:t_rtprio;
rtpp:p_rtprio;
name:array[0..31] of AnsiChar;
name:t_td_name;
begin
Result:=0;
rtpp:=nil;
@ -462,7 +464,7 @@ begin
rtpp:=@rtp;
end;
name[0]:=#0;
name:=Default(t_td_name);
if (param^.name<>nil) then
begin
@ -530,7 +532,7 @@ begin
RtlExitUserThread(0);
end;
function sys_thr_self(id:PQWORD):Integer;
function sys_thr_self(id:PDWORD):Integer;
var
td:p_kthread;
begin
@ -539,7 +541,7 @@ begin
td:=curkthread;
if (td=nil) then Exit(EFAULT);
Result:=suword64(id^,td^.td_tid);
Result:=suword32(id^,td^.td_tid);
if (Result<>0) then Exit(EFAULT);
Result:=0;
@ -582,7 +584,7 @@ begin
end;
end;
function sys_thr_kill(id:QWORD;sig:Integer):Integer;
function sys_thr_kill(id:DWORD;sig:Integer):Integer;
var
data:_t_stk;
begin
@ -592,7 +594,7 @@ begin
data.ksi.ksi_info.si_signo:=sig;
data.ksi.ksi_info.si_code :=SI_LWP;
if (int64(id)=-1) then
if (Integer(id)=-1) then
begin
if (sig<>0) and (not _SIG_VALID(sig)) then
begin
@ -702,7 +704,7 @@ begin
Result:=kern_thr_suspend(td,tsp);
end;
function sys_thr_wake(id:QWORD):Integer;
function sys_thr_wake(id:DWORD):Integer;
var
td:p_kthread;
begin
@ -728,21 +730,21 @@ begin
thread_dec_ref(td);
end;
function sys_thr_set_name(id:QWORD;pname:PChar):Integer;
function sys_thr_set_name(id:DWORD;pname:PChar):Integer;
var
td:p_kthread;
name:array[0..31] of AnsiChar;
name:t_td_name;
begin
Result:=0;
name[0]:=#0;
name:=Default(t_td_name);
if (name<>nil) then
begin
Result:=copyinstr(pname,@name,32,nil);
if (Result<>0) then Exit;
end;
if (int64(id)=-1) then
if (Integer(id)=-1) then
begin
//TODO SetProcName
Exit;
@ -753,7 +755,7 @@ begin
thread_lock(td);
Move(name,td^.td_name,SizeOf(td^.td_name));
td^.td_name:=name;
SetThreadDebugName(td^.td_handle,'ps4:'+name);
thread_unlock(td);
@ -761,6 +763,41 @@ begin
thread_dec_ref(td);
end;
function strnlen(s:PChar;maxlen:ptrint):ptrint;
var
len:size_t;
begin
For len:=0 to maxlen-1 do
begin
if (s^=#0) then Break;
Inc(s);
end;
Exit(len);
end;
function sys_thr_get_name(id:DWORD;pname:PChar):Integer;
var
td:p_kthread;
name:t_td_name;
len:ptrint;
begin
Result:=0;
td:=tdfind(DWORD(id));
if (td=nil) then Exit(ESRCH);
thread_lock(td);
name:=td^.td_name;
thread_unlock(td);
len:=strnlen(name,31);
Result:=copyout(@name,pname,len+1);
thread_dec_ref(td);
end;
function sys_amd64_set_fsbase(base:Pointer):Integer;
var
td:p_kthread;

12
sys/kern/kern_umtx.pas
View File

@ -20,9 +20,9 @@ procedure umtx_thread_init(td:p_kthread);
procedure umtx_thread_exit(td:p_kthread);
procedure umtx_thread_fini(td:p_kthread);
function _sys_umtx_lock(mtx:p_umtx):Integer;
function _sys_umtx_unlock(mtx:p_umtx):Integer;
function _sys_umtx_op(obj:Pointer;op:Integer;val:QWORD;uaddr1,uaddr2:Pointer):Integer;
function sys__umtx_lock(mtx:p_umtx):Integer;
function sys__umtx_unlock(mtx:p_umtx):Integer;
function sys__umtx_op(obj:Pointer;op:Integer;val:QWORD;uaddr1,uaddr2:Pointer):Integer;
//
@ -2453,7 +2453,7 @@ begin
Result:=do_rw_unlock(td,obj);
end;
function _sys_umtx_lock(mtx:p_umtx):Integer;
function sys__umtx_lock(mtx:p_umtx):Integer;
var
td:p_kthread;
begin
@ -2463,7 +2463,7 @@ begin
Result:=_do_lock_umtx(td,mtx,td^.td_tid,0);
end;
function _sys_umtx_unlock(mtx:p_umtx):Integer;
function sys__umtx_unlock(mtx:p_umtx):Integer;
var
td:p_kthread;
begin
@ -2495,7 +2495,7 @@ begin
Result:=do_sem_wake(td,obj)
end;
function _sys_umtx_op(obj:Pointer;op:Integer;val:QWORD;uaddr1,uaddr2:Pointer):Integer;
function sys__umtx_op(obj:Pointer;op:Integer;val:QWORD;uaddr1,uaddr2:Pointer):Integer;
var
td:p_kthread;
begin

100
sys/kern/md_proc.pas Normal file
View File

@ -0,0 +1,100 @@
unit md_proc;
{$mode ObjFPC}{$H+}
{$CALLING SysV_ABI_CDecl}
interface
uses
ntapi,
windows;
var
g_pid:DWORD=0;
function cpuset_setproc(new:Ptruint):Integer;
function cpuset_getproc(var old:Ptruint):Integer;
function get_proc_prio():Integer;
function set_proc_prio(n:Integer):Integer;
implementation
function cpuset_setproc(new:Ptruint):Integer;
begin
Result:=NtSetInformationProcess(NtCurrentProcess,
ProcessAffinityMask,
@new,
SizeOf(QWORD));
end;
function cpuset_getproc(var old:Ptruint):Integer;
var
info:PROCESS_BASIC_INFORMATION;
begin
Result:=NtQueryInformationProcess(NtCurrentProcess,
ProcessBasicInformation,
@info,
SizeOf(info),
nil);
if (Result=0) then
begin
old:=info.AffinityMask;
end;
end;
function get_proc_prio():Integer;
var
info:PROCESS_PRIORITY_CLASS;
begin
Result:=NtQueryInformationProcess(NtCurrentProcess,
ProcessPriorityClass,
@info,
SizeOf(info),
nil);
if (Result=0) then
begin
Result:=0;
case info.PriorityClass of
PROCESS_PRIORITY_CLASS_IDLE :Result:=-20;
PROCESS_PRIORITY_CLASS_BELOW_NORMAL:Result:=-10;
PROCESS_PRIORITY_CLASS_NORMAL :Result:=0;
PROCESS_PRIORITY_CLASS_ABOVE_NORMAL:Result:=10;
PROCESS_PRIORITY_CLASS_HIGH :Result:=20;
else;
end;
end else
begin
Result:=0;
end;
end;
function set_proc_prio(n:Integer):Integer;
var
info:PROCESS_PRIORITY_CLASS;
begin
info.Foreground :=False;
info.PriorityClass:=PROCESS_PRIORITY_CLASS_NORMAL;
case n of
-20..-14:info.PriorityClass:=PROCESS_PRIORITY_CLASS_IDLE;
-13.. -7:info.PriorityClass:=PROCESS_PRIORITY_CLASS_BELOW_NORMAL;
-6.. 6:info.PriorityClass:=PROCESS_PRIORITY_CLASS_NORMAL;
7.. 13:info.PriorityClass:=PROCESS_PRIORITY_CLASS_ABOVE_NORMAL;
14.. 20:info.PriorityClass:=PROCESS_PRIORITY_CLASS_HIGH;
else;
end;
Result:=NtSetInformationProcess(NtCurrentProcess,
ProcessPriorityClass,
@info,
SizeOf(info));
end;
initialization
g_pid:=GetCurrentProcessId;
end.

115
sys/kern/md_thread.pas Normal file
View File

@ -0,0 +1,115 @@
unit md_thread;
{$mode ObjFPC}{$H+}
{$CALLING SysV_ABI_CDecl}
interface
uses
ntapi,
windows,
kern_thr;
Const
SYS_STACK_RSRV=64*1024;
SYS_STACK_SIZE=16*1024;
function cpu_thread_alloc(td:p_kthread):Integer;
function cpu_thread_free(td:p_kthread):Integer;
function cpuset_setaffinity(td:p_kthread;new:Ptruint):Integer;
procedure cpu_set_user_tls(td:p_kthread;base:Pointer);
function cpu_set_priority(td:p_kthread;prio:Integer):Integer;
function cpu_getstack(td:p_kthread):QWORD; inline;
implementation
function cpu_thread_alloc(td:p_kthread):Integer;
var
data:Pointer;
size:ULONG_PTR;
begin
data:=nil;
size:=SYS_STACK_RSRV;
Result:=NtAllocateVirtualMemory(
NtCurrentProcess,
@data,
0,
@size,
MEM_RESERVE,
PAGE_READWRITE
);
if (Result<>0) then Exit;
data:=data+SYS_STACK_RSRV-SYS_STACK_SIZE;
size:=SYS_STACK_SIZE;
Result:=NtAllocateVirtualMemory(
NtCurrentProcess,
@data,
0,
@size,
MEM_COMMIT,
PAGE_READWRITE
);
data:=data+SYS_STACK_SIZE;
td^.td_kstack:=data;
end;
function cpu_thread_free(td:p_kthread):Integer;
var
data:Pointer;
size:ULONG_PTR;
begin
data:=td^.td_kstack;
data:=data-SYS_STACK_RSRV;
size:=0;
Result:=NtFreeVirtualMemory(
NtCurrentProcess,
@data,
@size,
MEM_RELEASE
);
end;
function cpuset_setaffinity(td:p_kthread;new:Ptruint):Integer;
begin
td^.td_cpuset:=new;
Result:=NtSetInformationThread(td^.td_handle,ThreadAffinityMask,@new,SizeOf(Ptruint));
end;
procedure cpu_set_user_tls(td:p_kthread;base:Pointer); inline;
begin
td^.pcb_fsbase:=base;
td^.td_teb^.tcb:=base;
end;
function cpu_set_priority(td:p_kthread;prio:Integer):Integer;
begin
td^.td_priority:=prio;
Case prio of
0..255:prio:= 16;
256..496:prio:= 2;
497..526:prio:= 1;
527..556:prio:= 0;
557..586:prio:=-1;
587..767:prio:=-2;
else
prio:=-16;
end;
Result:=NtSetInformationThread(td^.td_handle,ThreadBasePriority,@prio,SizeOf(Integer));
end;
function cpu_getstack(td:p_kthread):QWORD; inline;
begin
Result:=td^.td_frame^.tf_rsp;
end;
end.

3
sys/kern/sched_ule.pas
View File

@ -24,7 +24,8 @@ function setrunnable(td:p_kthread):Integer;
implementation
uses
vm_machdep;
vm_machdep,
md_thread;
procedure sched_fork_thread(td,childtd:p_kthread);
begin

128
sys/kern/vm_machdep.pas
View File

@ -13,18 +13,6 @@ uses
trap,
kern_thr;
var
g_pid:DWORD=0;
function cpu_thread_alloc(td:p_kthread):Integer;
function cpu_thread_free(td:p_kthread):Integer;
function cpuset_setaffinity(td:p_kthread;new:Ptruint):Integer;
function cpuset_setproc(new:Ptruint):Integer;
function cpuset_getproc(var old:Ptruint):Integer;
procedure cpu_set_user_tls(td:p_kthread;base:Pointer);
function cpu_set_priority(td:p_kthread;prio:Integer):Integer;
function cpu_getstack(td:p_kthread):QWORD;
procedure ipi_sigreturn;
function ipi_send_cpu(td:p_kthread):Integer;
@ -45,7 +33,8 @@ uses
machdep,
md_context,
signal,
kern_sig;
kern_sig,
md_thread;
function ntw2px(n:Integer):Integer; inline;
begin
@ -135,121 +124,11 @@ begin
NtYieldExecution;
end;
Const
SYS_STACK_RSRV=64*1024;
SYS_STACK_SIZE=16*1024;
function cpu_thread_alloc(td:p_kthread):Integer;
var
data:Pointer;
size:ULONG_PTR;
begin
data:=nil;
size:=SYS_STACK_RSRV;
Result:=NtAllocateVirtualMemory(
NtCurrentProcess,
@data,
0,
@size,
MEM_RESERVE,
PAGE_READWRITE
);
if (Result<>0) then Exit;
data:=data+SYS_STACK_RSRV-SYS_STACK_SIZE;
size:=SYS_STACK_SIZE;
Result:=NtAllocateVirtualMemory(
NtCurrentProcess,
@data,
0,
@size,
MEM_COMMIT,
PAGE_READWRITE
);
data:=data+SYS_STACK_SIZE;
td^.td_kstack:=data;
end;
function cpu_thread_free(td:p_kthread):Integer;
var
data:Pointer;
size:ULONG_PTR;
begin
data:=td^.td_kstack;
data:=data-SYS_STACK_RSRV;
size:=0;
Result:=NtFreeVirtualMemory(
NtCurrentProcess,
@data,
@size,
MEM_RELEASE
);
end;
function cpuset_setaffinity(td:p_kthread;new:Ptruint):Integer;
begin
td^.td_cpuset:=new;
Result:=NtSetInformationThread(td^.td_handle,ThreadAffinityMask,@new,SizeOf(Ptruint));
end;
function cpuset_setproc(new:Ptruint):Integer;
begin
Result:=NtSetInformationProcess(NtCurrentProcess,ProcessAffinityMask,@new,SizeOf(QWORD));
end;
function cpuset_getproc(var old:Ptruint):Integer;
var
info:PROCESS_BASIC_INFORMATION;
begin
Result:=NtQueryInformationProcess(NtCurrentProcess,
ProcessBasicInformation,
@info,
SizeOf(PROCESS_BASIC_INFORMATION),
nil);
if (Result=0) then
begin
old:=info.AffinityMask;
end;
end;
procedure cpu_set_user_tls(td:p_kthread;base:Pointer); inline;
begin
td^.pcb_fsbase:=base;
td^.td_teb^.tcb:=base;
end;
function cpu_get_iflag(td:p_kthread):PInteger; inline;
begin
Result:=@td^.td_teb^.iflag;
end;
function cpu_set_priority(td:p_kthread;prio:Integer):Integer;
begin
td^.td_priority:=prio;
Case prio of
0..255:prio:= 16;
256..496:prio:= 2;
497..526:prio:= 1;
527..556:prio:= 0;
557..586:prio:=-1;
587..767:prio:=-2;
else
prio:=-16;
end;
Result:=NtSetInformationThread(td^.td_handle,ThreadBasePriority,@prio,SizeOf(Integer));
end;
function cpu_getstack(td:p_kthread):QWORD; inline;
begin
Result:=td^.td_frame^.tf_rsp;
end;
function IS_SYSTEM_STACK(td:p_kthread;rsp:qword):Boolean; inline;
begin
Result:=(rsp<=QWORD(td^.td_kstack)) and (rsp>(QWORD(td^.td_kstack)-SYS_STACK_SIZE));
@ -513,9 +392,6 @@ begin
PROC_UNLOCK;
end;
initialization
g_pid:=GetCurrentProcessId;
end.

8
sys/rtprio.pas
View File

@ -42,8 +42,8 @@ type
_prio:Word;
end;
function PRI_BASE(P:Word):Word; inline;
function RTP_PRIO_BASE(P:Word):Word; inline;
function PRI_BASE(P:Word):Word;
function RTP_PRIO_BASE(P:Word):Word;
function rtprio_thread(func,tid:Integer;rtp:p_rtprio):Integer;
function _rtprio(func,pid:Integer;rtp:p_rtprio):Integer;
@ -55,12 +55,12 @@ uses
thr_error,
kern_rtprio;
function PRI_BASE(P:Word):Word; inline;
function PRI_BASE(P:Word):Word;
begin
Result:=P and (not PRI_FIFO_BIT);
end;
function RTP_PRIO_BASE(P:Word):Word; inline;
function RTP_PRIO_BASE(P:Word):Word;
begin
Result:=P and (not PRI_FIFO_BIT);
end;

8
sys/sys_umtx.pas
View File

@ -89,28 +89,28 @@ end;
function _umtx_lock(mtx:p_umtx):Integer; assembler; nostackframe;
asm
movq _sys_umtx_lock,%rax
movq sys__umtx_lock,%rax
call fast_syscall
jmp cerror
end;
function _umtx_unlock(mtx:p_umtx):Integer; assembler; nostackframe;
asm
movq _sys_umtx_unlock,%rax
movq sys__umtx_unlock,%rax
call fast_syscall
jmp cerror
end;
function _umtx_op(obj:Pointer;op:Integer;val:QWORD;uaddr1,uaddr2:Pointer):Integer; assembler; nostackframe;
asm
movq _sys_umtx_op,%rax
movq sys__umtx_op,%rax
call fast_syscall
jmp cerror
end;
function _umtx_op_err(obj:Pointer;op:Integer;val:QWORD;uaddr1,uaddr2:Pointer):Integer; assembler; nostackframe;
asm
movq _sys_umtx_op,%rax
movq sys__umtx_op,%rax
call fast_syscall
end;

24
sys/test/project1.lpi
View File

@ -225,10 +225,6 @@
<Filename Value="..\vm\vmparam.pas"/>
<IsPartOfProject Value="True"/>
</Unit>
<Unit>
<Filename Value="..\vm\kern_resource.pas"/>
<IsPartOfProject Value="True"/>
</Unit>
<Unit>
<Filename Value="..\vm\vm_map.pas"/>
<IsPartOfProject Value="True"/>
@ -501,6 +497,26 @@
<Filename Value="..\fs\ufs\md_vnops.pas"/>
<IsPartOfProject Value="True"/>
</Unit>
<Unit>
<Filename Value="..\kern\kern_exit.pas"/>
<IsPartOfProject Value="True"/>
</Unit>
<Unit>
<Filename Value="..\kern\kern_resource.pas"/>
<IsPartOfProject Value="True"/>
</Unit>
<Unit>
<Filename Value="..\kern\kern_prot.pas"/>
<IsPartOfProject Value="True"/>
</Unit>
<Unit>
<Filename Value="..\kern\md_thread.pas"/>
<IsPartOfProject Value="True"/>
</Unit>
<Unit>
<Filename Value="..\kern\md_proc.pas"/>
<IsPartOfProject Value="True"/>
</Unit>
</Units>
</ProjectOptions>
<CompilerOptions>

11
sys/test/project1.lpr
View File

@ -31,7 +31,7 @@ uses
kern_condvar,
kern_osem,
kern_id,
sys_osem,
sys_osem,
kern_evf,
sys_evf,
rtprio,
@ -72,7 +72,10 @@ uses
null_vnops,
null_vfsops,
ufs,
vmount;
vmount,
kern_prot,
kern_resource,
md_proc;
var
mtx:umutex;
@ -1092,6 +1095,10 @@ begin
//test_map;
sys_init;
Writeln(get_proc_prio());
Writeln(set_proc_prio(14));
Writeln(get_proc_prio());
e:=_umtx_op(nil,UMTX_OP_RW_WRLOCK,0,nil,nil);
Writeln('me=',e,' _errno:',__error^);

1
sys/test/test.txt Normal file
View File

File diff suppressed because one or more lines are too long

2
sys/thr.pas
View File

@ -34,7 +34,7 @@ implementation
uses
trap,
thr_error,
vm_machdep;
md_proc;
function getpid:Integer;
begin

60
sys/vm/kern_resource.pas
View File

@ -1,60 +0,0 @@
unit kern_resource;
{$mode ObjFPC}{$H+}
{$CALLING SysV_ABI_CDecl}
interface
uses
vmparam,
vfile;
const
RLIMIT_CPU = 0; // maximum cpu time in seconds
RLIMIT_FSIZE = 1; // maximum file size
RLIMIT_DATA = 2; // data size
RLIMIT_STACK = 3; // stack size
RLIMIT_CORE = 4; // core file size
RLIMIT_RSS = 5; // resident set size
RLIMIT_MEMLOCK= 6; // locked-in-memory address space
RLIMIT_NPROC = 7; // number of processes
RLIMIT_NOFILE = 8; // number of open files
RLIMIT_SBSIZE = 9; // maximum size of all socket buffers
RLIMIT_VMEM =10; // virtual process size (incl. mmap)
RLIMIT_AS =RLIMIT_VMEM; // standard name for RLIMIT_VMEM
RLIMIT_NPTS =11; // pseudo-terminals
RLIMIT_SWAP =12; // swap used
function lim_max(which:Integer):QWORD;
function lim_cur(which:Integer):QWORD;
implementation
function lim_max(which:Integer):QWORD;
begin
Result:=0;
Case which of
RLIMIT_DATA :Result:=MAXDSIZ;
RLIMIT_STACK :Result:=MAXSSIZ;
RLIMIT_MEMLOCK:Result:=pageablemem;
RLIMIT_VMEM :Result:=pageablemem;
RLIMIT_NOFILE :Result:=maxfilesperproc;
else;
end;
end;
function lim_cur(which:Integer):QWORD;
begin
Result:=0;
Case which of
RLIMIT_DATA :Result:=MAXDSIZ;
RLIMIT_STACK :Result:=MAXSSIZ;
RLIMIT_MEMLOCK:Result:=pageablemem;
RLIMIT_VMEM :Result:=pageablemem;
RLIMIT_NOFILE :Result:=maxfilesperproc;
else;
end;
end;
end.

3435
tools/syscalls_gen/_sysent.pas Normal file
View File

File diff suppressed because it is too large Load Diff

64
tools/syscalls_gen/syscalls_gen.lpi Normal file
View File

@ -0,0 +1,64 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="12"/>
<PathDelim Value="\"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
<MainUnitHasScaledStatement Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<Title Value="syscalls_gen"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<BuildModes>
<Item Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
</RunParams>
<Units>
<Unit>
<Filename Value="syscalls_gen.lpr"/>
<IsPartOfProject Value="True"/>
</Unit>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="syscalls_gen"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="$(LazarusDir)\components\mpaslex"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf3"/>
</Debugging>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions>
<Item>
<Name Value="EAbort"/>
</Item>
<Item>
<Name Value="ECodetoolError"/>
</Item>
<Item>
<Name Value="EFOpenError"/>
</Item>
</Exceptions>
</Debugging>
</CONFIG>

398
tools/syscalls_gen/syscalls_gen.lpr Normal file
View File

@ -0,0 +1,398 @@
uses
Classes,
SysUtils,
gset,
mpaslex,
_sysent;
type
TRawStrCompare=class
class function c(var a,b:RawByteString):boolean; static;
end;
TRawStrSet=specialize TSet<RawByteString,TRawStrCompare>;
class function TRawStrCompare.c(var a,b:RawByteString):boolean;
var
count1,count2:SizeInt;
begin
Count1:=Length(a);
Count2:=Length(b);
Result:=(Count1<Count2) or (
(Count1=Count2) and (CompareMemRange(PChar(a),PChar(b),Count1)<0)
);
end;
var
Exclude:TRawStrSet;
Sysentu:TRawStrSet;
FileList:TStringList;
Procedure AddExclude(const s:RawByteString);
begin
Exclude.Insert(lowercase(Trim(s)));
end;
Function IsExclude(const s:RawByteString):Boolean;
begin
Result:=(Exclude.NFind(lowercase(Trim(s)))<>nil);
end;
type
TState=(sNone,sNameFunc,sBeforeParam,sParamName,sParamType,sAfterParam,sReturn,sEndFunc,sError);
type
TFuncDecl=class(TStringList)
public
funit:RawByteString;
fhead:RawByteString;
fname:RawByteString;
fretv:RawByteString;
end;
var
sysent_maxlen:Integer=0;
sysent_func:array[0..high(sysent_table)] of TFuncDecl;
procedure AddSysFunc(f:TFuncDecl);
var
i:Integer;
s:Boolean;
begin
s:=False;
For i:=0 to high(sysent_table) do
begin
if (lowercase(sysent_table[i].sy_name)=lowercase(f.fname)) then
begin
if (sysent_func[i]<>nil) then
begin
Writeln('Collision[',i:3,']:',f.fname,' prev unit:',sysent_func[i].funit,' new unit:',f.funit);
end else
begin
Writeln('Found[',i:3,']:',f.fname:sysent_maxlen,' in unit:',f.funit);
sysent_func[i]:=f;
s:=True;
end;
end;
end;
if not s then
begin
FreeAndNil(f);
end;
end;
Procedure load_pas(const fname:RawByteString);
var
F:THandle;
size:Int64;
buf:PChar;
state:TState;
i:Integer;
token:RawByteString;
FuncDecl:TFuncDecl;
procedure add_to_param(S:RawByteString);
begin
S:=Trim(S);
if (S='') then S:=' ';
token:=Trim(token)+S;
end;
begin
if (fname='') then Exit;
F:=FileOpen(fname,fmOpenRead or fmShareDenyNone);
if (F=feInvalidHandle) then
begin
Writeln('Error open file:',fname);
Exit;
end;
size:=FileSeek(F,0,fsFromEnd);
FileSeek(F,0,fsFromBeginning);
buf:=AllocMem(size+1);
FileRead(F,buf^,size);
mwPasLex.Origin:=buf;
FuncDecl:=nil;
state:=sNone;
while (mwPasLex.RunPos<size) do
begin
mwPasLex.Next;
Case mwPasLex.TokenID of
tkInterface:Break;
else;
end;
end;
while (mwPasLex.RunPos<size) do
begin
case state of
sParamName,
sParamType,
sReturn :mwPasLex.Next;
else
mwPasLex.NextNoJunk;
end;
Case mwPasLex.TokenID of
tkImplementation:Break;
else;
end;
case state of
sNone:
begin
Case mwPasLex.TokenID of
tkProcedure,
tkFunction :
begin
FuncDecl:=TFuncDecl.Create;
FuncDecl.NameValueSeparator:=':';
FuncDecl.funit:=ChangeFileExt(ExtractFileName(fname),'');
FuncDecl.fhead:=mwPasLex.Token;
state:=sNameFunc;
end;
else;
end;
end;
sNameFunc:
begin
//Writeln(mwPasLex.TokenID);
Case mwPasLex.TokenID of
tkIdentifier :
begin
token:=mwPasLex.Token;
if (LowerCase(Copy(token,1,4))='sys_') then
begin
FuncDecl.fname:=token;
token:='';
state:=sBeforeParam;
end else
begin
state:=sError;
end;
end
else
state:=sError;
end;
end;
sBeforeParam:
begin
Case mwPasLex.TokenID of
tkRoundOpen:state:=sParamName;
tkColon :
begin
token:='';
state:=sReturn;
end;
tkSemiColon:state:=sEndFunc;
else;
state:=sError;
end;
end;
sParamName:
begin
//Writeln(mwPasLex.TokenID,':*',mwPasLex.Token,'*');
Case mwPasLex.TokenID of
tkColon :
begin
state:=sParamType;
add_to_param(mwPasLex.Token);
end;
tkRoundClose:state:=sAfterParam;
else
add_to_param(mwPasLex.Token);
end;
end;
sParamType:
begin
//Writeln(mwPasLex.TokenID,':*',mwPasLex.Token,'*');
Case mwPasLex.TokenID of
tkSemiColon :
begin
FuncDecl.Add(token);
token:='';
state:=sParamName;
end;
tkRoundClose:
begin
FuncDecl.Add(token);
token:='';
state:=sAfterParam;
end;
else
add_to_param(mwPasLex.Token);
end;
end;
sAfterParam:
begin
Case mwPasLex.TokenID of
tkColon:
begin
token:='';
state:=sReturn;
end;
tkSemiColon:state:=sEndFunc;
else;
state:=sError;
end;
end;
sReturn:
begin
Case mwPasLex.TokenID of
tkSemiColon:
begin
FuncDecl.fretv:=token;
token:='';
state:=sEndFunc;
end;
else
add_to_param(mwPasLex.Token);
end;
end;
else;
end;
case state of
sError:
begin
state:=sNone;
FreeAndNil(FuncDecl);
end;
sEndFunc:
begin
state:=sNone;
if (Sysentu.NFind(lowercase(FuncDecl.fname))<>nil) then
begin
AddSysFunc(FuncDecl);
FuncDecl:=nil;
{
Write(FuncDecl.fhead,' ',FuncDecl.fname,'(');
if (FuncDecl.Count<>0) then
For i:=0 to FuncDecl.Count-1 do
begin
Write(FuncDecl.Strings[i]);
if (i<>FuncDecl.Count-1) then
begin
Write(';');
end;
end;
Write(')');
if (FuncDecl.fretv<>'') then
begin
Write(':',FuncDecl.fretv);
end;
Writeln(';');
}
end;
end;
else;
end;
end;
FreeMem(buf);
FileClose(F);
end;
procedure LoadRecrusive(const basep,reltv:RawByteString);
Var
Info:TSearchRec;
f:RawByteString;
begin
f:=IncludeTrailingPathDelimiter(IncludeTrailingPathDelimiter(basep)+reltv);
If FindFirst(f+'*',faDirectory,Info)=0 then
begin
Repeat
Case Info.Name of
'.','..':;
else
if not IsExclude(Info.Name) then
begin
If ((Info.Attr and faDirectory)<>0) then
begin
LoadRecrusive(basep,IncludeTrailingPathDelimiter(reltv)+Info.Name);
end else
if (lowercase(ExtractFileExt(Info.Name))='.pas') then
begin
FileList.Add(IncludeTrailingPathDelimiter(reltv)+Info.Name);
//Writeln(IncludeTrailingPathDelimiter(reltv)+Info.Name);
load_pas(basep+IncludeTrailingPathDelimiter(reltv)+Info.Name);
end;
end;
end;
Until FindNext(info)<>0;
FindClose(Info);
end;
end;
procedure LoadSysent;
var
i:Integer;
begin
For i:=0 to high(sysent_table) do
begin
if (sysent_table[i].sy_call=nil) then
begin
if Length(sysent_table[i].sy_name)>sysent_maxlen then sysent_maxlen:=Length(sysent_table[i].sy_name);
Sysentu.Insert(lowercase(sysent_table[i].sy_name));
end;
end;
end;
procedure LoadStats;
var
i:Integer;
f,n:Integer;
begin
f:=0;
n:=0;
For i:=0 to high(sysent_table) do
begin
if (sysent_table[i].sy_call=nil) then
begin
if (sysent_func[i]<>nil) then
begin
Inc(f);
end else
begin
Writeln('Not found[',i:3,']:',sysent_table[i].sy_name:sysent_maxlen);
Inc(n);
end;
end;
end;
Writeln('syscalls status:',f,'/',f+n,':%',(f/(f+n))*100:0:2);
end;
begin
mwPasLex:=TmwPasLex.Create;
Exclude:=TRawStrSet.Create;
Sysentu:=TRawStrSet.Create;
FileList:=TStringList.Create;
AddExclude('backup');
LoadSysent;
LoadRecrusive('..\..\sys','');
LoadStats;
readln;
end.