+

fpPS4.lpi

@@ -854,6 +854,10 @@
         <Filename Value="sys\sys_conf.pas"/>
         <IsPartOfProject Value="True"/>
       </Unit>
+      <Unit>
+        <Filename Value="sys\md\md_game_process.pas"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
     </Units>
   </ProjectOptions>
   <CompilerOptions>

gui/game_edit.pas

@@ -34,6 +34,11 @@ type
     procedure GridSelectEditor(Sender:TObject;aCol,aRow:Integer;var Editor:TWinControl);
     procedure GridEditingDone(Sender: TObject);
   private
+    Fapp0_row   :Integer;
+    FName_row   :Integer;
+    FTitleId_row:Integer;
+    FVersion_row:Integer;
+
     Fapp0p:RawByteString;
   public
     OnSave  :TNotifyEvent;
@@ -227,6 +232,13 @@ begin
   begin
    For i:=0 to c-1 do
    begin
+    case A[i].Name of
+     'Name'   :FName_row   :=GridMain.RowCount;
+     'TitleId':FTitleId_row:=GridMain.RowCount;
+     'Version':FVersion_row:=GridMain.RowCount;
+     else;
+    end;
+
     AddRow(GridMain,A[i].Name+':',A[i].GetValue(Item.FGameInfo).AsString,nil);
    end;
   end;
@@ -238,6 +250,11 @@ begin
   begin
    For i:=0 to c-1 do
    begin
+    case A[i].Name of
+     'app0':Fapp0_row:=GridMounts.RowCount;
+     else;
+    end;
+
     AddRow(GridMounts,'/'+A[i].Name,A[i].GetValue(Item.FMountList).AsString,fip);
    end;
   end;
@@ -246,10 +263,6 @@ begin
   Ctx.free;
  end;
 
- //AddRow(GridMounts,'/app0'  ,ip);
- //AddRow(GridMounts,'/system',ip);
- //AddRow(GridMounts,'/data'  ,ip);
-
  LoadParamSfo(UpdateTitle);
 
  Show;
@@ -294,25 +307,19 @@ begin
  end;
 end;
 
-function GetGridVal(Grid:TStringGrid;const name:RawByteString):RawByteString;
+function GetGridVal(Grid:TStringGrid;ARow:Integer):RawByteString;
-var
- i:Integer;
 begin
  Result:='';
- i:=Grid.Cols[0].IndexOf(name);
+ if (ARow<0) and (ARow>=Grid.RowCount) then Exit;
- if (i=-1) then Exit;
  //
- Result:=Grid.Cells[1,i];
+ Result:=Grid.Cells[1,ARow];
 end;
 
-procedure SetGridVal(Grid:TStringGrid;const name,value:RawByteString);
+procedure SetGridVal(Grid:TStringGrid;ARow:Integer;const value:RawByteString);
-var
- i:Integer;
 begin
- i:=Grid.Cols[0].IndexOf(name);
+ if (ARow<0) and (ARow>=Grid.RowCount) then Exit;
- if (i=-1) then Exit;
  //
- Grid.Cells[1,i]:=value;
+ Grid.Cells[1,ARow]:=value;
 end;
 
 procedure TfrmGameEditor.LoadParamSfo(UpdateTitle:Boolean);
@@ -320,7 +327,7 @@ var
  i:Integer;
  V:RawByteString;
 begin
- V:=GetGridVal(GridMounts,'/app0');
+ V:=GetGridVal(GridMounts,Fapp0_row);
 
  if (Fapp0p=V) then Exit;
 
@@ -357,13 +364,13 @@ begin
  if not UpdateTitle then Exit;
 
  V:=ParamSfo.GetString('TITLE');
- SetGridVal(GridMain,'Name:',V);
+ SetGridVal(GridMain,FName_row,V);
 
  V:=ParamSfo.GetString('TITLE_ID');
- SetGridVal(GridMain,'TitleId:',V);
+ SetGridVal(GridMain,FTitleId_row,V);
 
  V:=ParamSfo.GetString('VERSION');
- SetGridVal(GridMain,'Version:',V);
+ SetGridVal(GridMain,FVersion_row,V);
 end;
 
 procedure TfrmGameEditor.GridSelectEditor(Sender:TObject;aCol,aRow:Integer;var Editor:TWinControl);

gui/game_info.pas

@@ -7,7 +7,8 @@ interface
 uses
   Classes,
   SysUtils,
-  IniFiles;
+  IniFiles,
+  host_ipc;
 
 type
  TAbstractInfo=class
@@ -69,11 +70,49 @@ type
    Procedure   Deserialize(Stream:TStream); override;
  end;
 
+ TGameProcess=class
+  g_ipc  :THostIpcConnect;
+  g_proc :THandle;
+  g_p_pid:Integer;
+  g_fork :Boolean;
+  function   is_terminated:Boolean; virtual;
+  procedure  suspend; virtual;
+  procedure  resume;  virtual;
+  procedure  stop;    virtual;
+  Destructor Destroy; override;
+ end;
+
 implementation
 
 uses
  TypInfo,Rtti;
 
+function TGameProcess.is_terminated:Boolean;
+begin
+ Result:=False;
+end;
+
+procedure TGameProcess.suspend;
+begin
+ //
+end;
+
+procedure TGameProcess.resume;
+begin
+ //
+end;
+
+procedure TGameProcess.stop;
+begin
+ //
+end;
+
+Destructor TGameProcess.Destroy;
+begin
+ FreeAndNil(g_ipc);
+ inherited;
+end;
+
 Procedure TAbstractInfo.Serialize(Stream:TStream);
 var
  i,c:Integer;

gui/game_run.pas

@@ -23,22 +23,14 @@ type
   fork_proc:Boolean;
  end;
 
- TGameProcess=class
-  g_ipc :THostIpcConnect;
-  g_fork:Boolean;
- end;
-
  TGameProcessSimple=class(TGameProcess)
   Ftd:p_kthread;
- end;
+  procedure  suspend; override;
-
+  procedure  resume;  override;
- TGameProcessPipe=class(TGameProcess)
+  Destructor Destroy; override;
-  FProcess:THandle;
-  FChild:THandle;
  end;
 
 var
-
  kern_ipc:THostIpcConnect=nil;
 
 function run_item(const cfg:TGameRunConfig;Item:TGameItem):TGameProcess;
@@ -60,6 +52,8 @@ uses
  kern_proc,
  md_systm,
 
+ md_game_process,
+
  //internal libs
  ps4_libSceSystemService,
  ps4_libSceUserService,
@@ -70,6 +64,24 @@ uses
 
  ;
 
+//
+
+procedure  TGameProcessSimple.suspend;
+begin
+ thread_suspend_all(Ftd);
+end;
+
+procedure  TGameProcessSimple.resume;
+begin
+ thread_resume_all(Ftd);
+end;
+
+Destructor TGameProcessSimple.Destroy;
+begin
+ thread_dec_ref(Ftd);
+ inherited;
+end;
+
 var
  runing:Boolean=False;
 
@@ -252,7 +264,7 @@ begin
    p_mgui_ipc.set_pipe(kern2mgui[0]);
 
    g_ipc:=p_mgui_ipc;
-   FChild:=kern2mgui[1];
+   FChildpip:=kern2mgui[1];
   end;
 
   //
@@ -263,12 +275,15 @@ begin
 
   Item.Serialize(mem);
 
-  r:=md_fork_process(@fork_process,mem.Memory,mem.Size,fork_info);
+  fork_info.hInput :=GetStdHandle(STD_INPUT_HANDLE);
+  fork_info.hOutput:=cfg.hOutput;
+  fork_info.hError :=cfg.hError;
 
-  with TGameProcessPipe(Result) do
+  fork_info.proc:=@fork_process;
-  begin
+  fork_info.data:=mem.Memory;
-   FProcess:=fork_info.hProcess;
+  fork_info.size:=mem.Size;
-  end;
+
+  r:=md_fork_process(fork_info);
 
   mem.Free;
  end else
@@ -297,6 +312,9 @@ begin
 
  end;
 
+ Result.g_proc :=fork_info.hProcess;
+ Result.g_p_pid:=fork_info.fork_pid;
+
  Result.g_ipc.thread_new;
 
  kev.ident :=fork_info.fork_pid;

gui/main.pas

@@ -7,6 +7,15 @@ interface
 uses
   Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ComCtrls, Grids, Menus,
 
+  g_bufstream,
+  LineStream,
+  synlog,
+  SynEditLineStream,
+  LazSynEditText,
+  SynEditMarkupBracket,
+
+  IniFiles,
+
   game_info,
   game_edit,
   game_run,
@@ -42,7 +51,21 @@ type
   private
 
   public
-    GameProcess:TGameProcess;
+    FGameProcess:TGameProcess;
+
+    FIniFile:TIniFile;
+
+    FMainInfo:TMainInfo;
+
+    FAddHandle:THandle;
+    FGetHandle:THandle;
+
+    FFile:TStream;
+    FList:TSynEditLineStream;
+
+    Fmlog:TCustomSynLog;
+
+    FLogUpdateTime:QWORD;
 
     procedure ReadIniFile;
     procedure LoadItemIni(Item:TGameItem);
@@ -54,6 +77,8 @@ type
     procedure DelItemRow(Item:TGameItem);
     procedure DoAdd(Sender: TObject);
     procedure DoEdit(Sender: TObject);
+    procedure LogEnd;
+    procedure ClearLog;
   end;
 
 var
@@ -66,15 +91,6 @@ uses
 
  md_arc4random,
 
- g_bufstream,
- LineStream,
- synlog,
- SynEditLineStream,
- LazSynEditText,
- SynEditMarkupBracket,
-
- IniFiles,
-
  TypInfo,
  Rtti,
 
@@ -82,39 +98,33 @@ uses
 
 //
 
-var
- FIniFile:TIniFile;
-
- FMainInfo:TMainInfo;
-
- FAddHandle:THandle;
- FGetHandle:THandle;
-
- FFile:TStream;
- FList:TSynEditLineStream;
-
 {$R *.lfm}
 
 { TfrmMain }
 
 type
  TMySynLog=class(TCustomSynLog)
-  function LinesCreate:TSynEditStringListBase; override;
+  Form:TfrmMain;
+  constructor Create(AOwner: TComponent; AForm:TfrmMain);
+  function    LinesCreate:TSynEditStringListBase; override;
  end;
 
+constructor TMySynLog.Create(AOwner: TComponent; AForm:TfrmMain);
+begin
+ Form:=AForm;
+ inherited Create(AOwner);
+end;
+
 function TMySynLog.LinesCreate:TSynEditStringListBase;
 begin
- FList:=TSynEditLineStream.Create;
+ Form.FList:=TSynEditLineStream.Create;
 
- FList.FSynLog:=Self;
+ Form.FList.FSynLog:=Self;
- FList.FStream:=TLineStream.Create(FFile);
+ Form.FList.FStream:=TLineStream.Create(Form.FFile);
 
- Result:=FList;
+ Result:=Form.FList;
 end;
 
-var
- mlog:TMySynLog;
-
 const
  section_prefix='game-';
 
@@ -301,22 +311,19 @@ begin
 
  FFile:=TBufferedFileStream.Create(FGetHandle);
 
- mlog:=TMySynLog.Create(TabLog);
+ Fmlog:=TMySynLog.Create(TabLog,Self);
- mlog.Parent:=TabLog;
+ Fmlog.Parent:=TabLog;
 
- mlog.Align:=alClient;
+ Fmlog.Align:=alClient;
 
- mlog.BracketHighlightStyle:=sbhsBoth;
+ Fmlog.BracketHighlightStyle:=sbhsBoth;
- mlog.Font.Style:=[];
+ Fmlog.Font.Style:=[];
 
  Pages.ActivePageIndex:=0;
 
  Application.AddOnIdleHandler(@OnIdleUpdate,False);
 end;
 
-Var
- FLogUpdateTime:QWORD=0;
-
 procedure TfrmMain.OnIdleUpdate(Sender:TObject;var Done:Boolean);
 begin
  Done:=True;
@@ -330,10 +337,10 @@ begin
   FLogUpdateTime:=GetTickCount64;
  end;
 
- if (GameProcess<>nil) then
+ if (FGameProcess<>nil) then
- if (GameProcess.g_ipc<>nil) then
+ if (FGameProcess.g_ipc<>nil) then
  begin
-  GameProcess.g_ipc.Update(IpcHandler);
+  FGameProcess.g_ipc.Update(IpcHandler);
  end;
 
 end;
@@ -404,6 +411,19 @@ begin
  form.FormInit(False);
 end;
 
+procedure TfrmMain.LogEnd;
+begin
+ Fmlog.TopLine:=Fmlog.Lines.Count;
+end;
+
+procedure TfrmMain.ClearLog;
+begin
+ //reset file
+ FileTruncate(FAddHandle,0);
+ FList.Reset;
+ //
+end;
+
 procedure TfrmMain.MIRunClick(Sender: TObject);
 var
  Item:TGameItem;
@@ -417,12 +437,8 @@ begin
 
  Item:=GetItemRow(aRow);
 
- FList.FSynLog.TopLine:=FList.FSynLog.Lines.Count;
+ LogEnd;
-
+ ClearLog;
- //reset file
- FileTruncate(FAddHandle,0);
- FList.Reset;
- //
 
  Pages.ActivePage:=TabLog;
 
@@ -431,7 +447,7 @@ begin
 
  cfg.fork_proc:=True;
 
- GameProcess:=run_item(cfg,Item);
+ FGameProcess:=run_item(cfg,Item);
 end;
 
 procedure TfrmMain.MIDelClick(Sender: TObject);

sys/kern/kern_exit.pas

@@ -128,6 +128,8 @@ begin
  Result:=(ret shl 8) or sig;
 end;
 
+procedure thread_suspend_all(exclude:Pointer); external;
+
 procedure exit1(rv:Integer);
 begin
  //Notify interested parties of our demise.
@@ -138,6 +140,7 @@ begin
   md_halt(rv);
  end else
  begin
+  thread_suspend_all(nil);
   msleep_td(0);
  end;
 end;

sys/kern/kern_sig.pas

@@ -127,7 +127,6 @@ uses
  kern_prot,
  kern_synch,
  md_context,
- md_proc,
  machdep,
  sched_ule,
  sys_sleepqueue;

sys/kern/kern_thread.pas

@@ -56,6 +56,9 @@ procedure threadinit; //SYSINIT
 function  kthread_add (func,arg:Pointer;newtdp:pp_kthread;name:PChar):Integer;
 procedure kthread_exit();
 
+procedure thread_suspend_all(exclude:p_kthread);
+procedure thread_resume_all (exclude:p_kthread);
+
 var
  init_tty_cb:Tprocedure;
 
@@ -815,6 +818,52 @@ begin
  // NOTREACHED
 end;
 
+procedure thread_suspend_all(exclude:p_kthread); public;
+var
+ td,ttd:p_kthread;
+begin
+ td:=curkthread;
+
+ threads_lock;
+
+   ttd:=TAILQ_FIRST(@p_threads);
+   while (ttd<>nil) do
+   begin
+
+    if (ttd<>td) and (ttd<>exclude) then
+    begin
+     md_suspend(ttd);
+    end;
+
+    ttd:=TAILQ_NEXT(ttd,@ttd^.td_plist)
+   end;
+
+ threads_unlock;
+end;
+
+procedure thread_resume_all(exclude:p_kthread); public;
+var
+ td,ttd:p_kthread;
+begin
+ td:=curkthread;
+
+ threads_lock;
+
+   ttd:=TAILQ_FIRST(@p_threads);
+   while (ttd<>nil) do
+   begin
+
+    if (ttd<>td) and (ttd<>exclude) then
+    begin
+     md_resume(ttd);
+    end;
+
+    ttd:=TAILQ_NEXT(ttd,@ttd^.td_plist)
+   end;
+
+ threads_unlock;
+end;
+
 function sys_thr_kill(id,sig:Integer):Integer;
 var
  td,ttd:p_kthread;

sys/md/md_game_process.pas

@@ -0,0 +1,59 @@
+unit md_game_process;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+ windows,
+ ntapi,
+ game_info;
+
+type
+ TGameProcessPipe=class(TGameProcess)
+  FChildpip:THandle;
+  function   is_terminated:Boolean; override;
+  procedure  suspend; override;
+  procedure  resume;  override;
+  procedure  stop;    override;
+  Destructor Destroy; override;
+ end;
+
+implementation
+
+function TGameProcessPipe.is_terminated:Boolean;
+var
+ R:DWORD;
+ T:QWORD;
+begin
+ T:=0;
+ R:=NtWaitForSingleObject(g_proc,False,@T);
+
+ Result:=(R=STATUS_WAIT_0);
+end;
+
+procedure TGameProcessPipe.suspend;
+begin
+ NtSuspendProcess(g_proc);
+end;
+
+procedure TGameProcessPipe.resume;
+begin
+ NtResumeProcess(g_proc);
+end;
+
+procedure TGameProcessPipe.stop;
+begin
+ NtTerminateProcess(g_proc,0);
+end;
+
+Destructor TGameProcessPipe.Destroy;
+begin
+ CloseHandle(g_proc);
+ CloseHandle(FChildpip);
+ inherited;
+end;
+
+
+end.
+

sys/md/md_systm.pas

@@ -15,8 +15,16 @@ type
 
  p_fork_proc=^t_fork_proc;
  t_fork_proc=record
-  hProcess:THandle;
+  hInput :THandle;  //in
-  fork_pid:Integer;
+  hOutput:THandle;  //in
+  hError :THandle;  //in
+
+  proc:Pointer;     //in
+  data:Pointer;     //in
+  size:QWORD;       //in
+
+  hProcess:THandle; //out
+  fork_pid:Integer; //out
  end;
 
 function  md_copyin (hProcess:THandle;udaddr,kaddr:Pointer;len:ptruint;lencopied:pptruint):Integer;
@@ -31,7 +39,7 @@ function  md_pidfd_open (pid:DWORD):THandle;
 
 procedure md_run_forked;
 procedure md_fork_unshare;
-function  md_fork_process(proc:Pointer;data:Pointer;size:QWORD;var info:t_fork_proc):Integer;
+function  md_fork_process(var info:t_fork_proc):Integer;
 
 implementation
 
@@ -435,7 +443,7 @@ begin
  Exit(hProcJob);
 end;
 
-function NtCreateShared(hProcess:THandle;proc:Pointer;data:Pointer;size:QWORD):Integer;
+function NtCreateShared(hProcess:THandle;var info:t_fork_proc):Integer;
 var
  base:p_shared_info;
  full:QWORD;
@@ -443,8 +451,8 @@ var
 begin
  base:=Pointer(WIN_SHARED_ADDR);
 
- full:=SizeOf(shared_info)+size;
+ full:=SizeOf(shared_info)+info.size;
- full:=(size+(MD_PAGE_SIZE-1)) and (not (MD_PAGE_SIZE-1));
+ full:=(info.size+(MD_PAGE_SIZE-1)) and (not (MD_PAGE_SIZE-1));
 
  Result:=md_mmap(hProcess,base,full,MD_PROT_RW);
  if (Result<>0) then Exit;
@@ -453,36 +461,38 @@ begin
 
  shared_info.ppid      :=GetCurrentProcessId;
 
- shared_info.hStdInput :=md_dup_to_pidfd(hProcess,GetStdHandle(STD_INPUT_HANDLE));
+ shared_info.hStdInput :=md_dup_to_pidfd(hProcess,info.hInput );
- shared_info.hStdOutput:=md_dup_to_pidfd(hProcess,GetStdHandle(STD_OUTPUT_HANDLE));
+ shared_info.hStdOutput:=md_dup_to_pidfd(hProcess,info.hOutput);
- shared_info.hStdError :=md_dup_to_pidfd(hProcess,GetStdHandle(STD_ERROR_HANDLE));
+ shared_info.hStdError :=md_dup_to_pidfd(hProcess,info.hError );
 
- shared_info.proc:=proc;
+ shared_info.proc:=info.proc;
- shared_info.size:=size;
+ shared_info.size:=info.size;
 
  Result:=md_copyout(hProcess,@shared_info,base,SizeOf(shared_info),nil);
  if (Result<>0) then Exit;
 
- if (data<>nil) and (size<>0) then
+ if (info.data<>nil) and (info.size<>0) then
  begin
-  Result:=md_copyout(hProcess,data,@base^.data,size,nil);
+  Result:=md_copyout(hProcess,info.data,@base^.data,info.size,nil);
  end;
 end;
 
-function md_fork_process(proc:Pointer;data:Pointer;size:QWORD;var info:t_fork_proc):Integer;
+function md_fork_process(var info:t_fork_proc):Integer;
-var
+type
- si:TSTARTUPINFO;
+ TBUF_PROC_INFO=packed record
- pi:PROCESS_INFORMATION;
- BUF:packed record
   UNAME:UNICODE_STRING;
   DATA :array[0..MAX_PATH*2] of WideChar;
  end;
+var
+ si:TSTARTUPINFO;
+ pi:PROCESS_INFORMATION;
+ BUF:TBUF_PROC_INFO;
  LEN:ULONG;
  b:BOOL;
 begin
  Result:=0;
 
- FillChar(BUF,SizeOf(BUF),0);
+ BUF:=Default(TBUF_PROC_INFO);
  LEN:=SizeOf(BUF);
 
  Result:=NtQueryInformationProcess(NtCurrentProcess,
@@ -509,7 +519,7 @@ begin
  Result:=NtReserve(pi.hProcess);
  if (Result<>0) then Exit;
 
- Result:=NtCreateShared(pi.hProcess,proc,data,size);
+ Result:=NtCreateShared(pi.hProcess,info);
  if (Result<>0) then Exit;
 
  Result:=NtResumeProcess(pi.hProcess);

sys/md/md_thread.pas

@@ -35,6 +35,9 @@ function  cpu_set_priority(td:p_kthread;prio:Integer):Integer;
 
 function  cpu_thread_set_name(td:p_kthread;const name:shortstring):Integer;
 
+function  md_suspend(td:p_kthread):Integer;
+function  md_resume (td:p_kthread):Integer;
+
 procedure seh_wrapper_before(td:p_kthread;var func:Pointer);
 procedure seh_wrapper_after (td:p_kthread;func:Pointer);
 
@@ -344,6 +347,34 @@ begin
  Result:=NtSetInformationThread(td^.td_handle,ThreadNameInformation,@UNAME,SizeOf(UNAME));
 end;
 
+function md_suspend(td:p_kthread):Integer;
+var
+ count:ULONG;
+begin
+ Result:=0;
+ if (td=nil) then Exit;
+ if (td^.td_handle=0) or (td^.td_handle=THandle(-1)) then Exit;
+
+ count:=0;
+ NtSuspendThread(td^.td_handle,@count);
+
+ Result:=count;
+end;
+
+function md_resume(td:p_kthread):Integer;
+var
+ count:ULONG;
+begin
+ Result:=0;
+ if (td=nil) then Exit;
+ if (td^.td_handle=0) or (td^.td_handle=THandle(-1)) then Exit;
+
+ count:=0;
+ NtResumeThread(td^.td_handle,@count);
+
+ Result:=count;
+end;
+
 procedure main_wrapper; assembler; nostackframe;
 asm
  subq   $40, %rsp