+

gui/game_run.pas

@@ -244,7 +244,6 @@ var
  mem:TMemoryStream;
 begin
  Result:=nil;
- if Item.FLock then Exit;
 
  SetStdHandle(STD_OUTPUT_HANDLE,cfg.hOutput);
  SetStdHandle(STD_ERROR_HANDLE ,cfg.hError );

gui/main.pas

@@ -74,6 +74,7 @@ type
 
   public
     FGameProcess:TGameProcess;
+    FGameItem   :TGameItem;
 
     FIniFile:TIniFile;
 
@@ -93,8 +94,10 @@ type
 
     FGameMainForm:TGameMainForm;
 
+    function  get_caption_format:RawByteString;
     function  OpenMainWindows():THandle;
     Procedure CloseMainWindows();
+    procedure SetCaptionFPS(Ffps:QWORD);
 
     procedure ReadIniFile;
     procedure LoadItemIni(Item:TGameItem);
@@ -179,6 +182,7 @@ begin
  case mtype of
   iKEV_EVENT   :Result:=OnKevent(buf,mlen div sizeof(t_kevent));
   iMAIN_WINDOWS:Result:=Form.OpenMainWindows();
+  iCAPTION_FPS :Form.SetCaptionFPS(PQWORD(buf)^);
   else;
    ShowMessage(GetEnumName(TypeInfo(mtype),ord(mtype)));
  end;
@@ -396,6 +400,29 @@ begin
 
 end;
 
+function TfrmMain.get_caption_format:RawByteString;
+var
+ TITLE,TITLE_ID,APP_VER:RawByteString;
+begin
+ Result:='';
+
+ if (FGameItem=nil) then Exit;
+
+ TITLE   :=FGameItem.FGameInfo.Name;
+ TITLE_ID:=FGameItem.FGameInfo.TitleId;
+ APP_VER :=FGameItem.FGameInfo.Version;
+
+ if (TITLE='') then
+ begin
+  TITLE:=ExtractFileName(FGameItem.FGameInfo.Exec);
+ end;
+
+ if (TITLE_ID<>'') then TITLE_ID:='-' +TITLE_ID;
+ if (APP_VER <>'') then APP_VER :=':v'+APP_VER;
+
+ Result:=Format('fpPS4 (%s) [%s%s%s]',[{$I tag.inc},TITLE,TITLE_ID,APP_VER])+' FPS:%d';
+end;
+
 function TfrmMain.OpenMainWindows():THandle;
 const
  pd_Width=1280;
@@ -409,7 +436,7 @@ begin
  FGameMainForm.ParentDoubleBuffered:=False;
  FGameMainForm.FormStyle:=fsNormal;
  FGameMainForm.SetBounds(100, 100, pd_Width, pd_Height);
- //FGameMainForm.caption_format:=get_caption_format;
+ FGameMainForm.caption_format:=get_caption_format;
  FGameMainForm.SetCaptionFPS(0);
  //FGameMainForm.OnClose:=@FGameMainForm.CloseEvent;
  //FGameMainForm.OnKeyDown:=@FGameMainForm.KeyEvent;
@@ -428,6 +455,13 @@ begin
  FreeAndNil(FGameMainForm);
 end;
 
+procedure TfrmMain.SetCaptionFPS(Ffps:QWORD);
+begin
+ if (FGameMainForm=nil) then Exit;
+
+ FGameMainForm.SetCaptionFPS(Ffps);
+end;
+
 procedure TfrmMain.MIAddClick(Sender: TObject);
 var
  form:TfrmGameEditor;
@@ -530,11 +564,19 @@ begin
  cfg.hOutput:=FAddHandle;
  cfg.hError :=FAddHandle;
 
- cfg.fork_proc:=False;
+ cfg.fork_proc:=True;
+
+ if Item.FLock then Exit;
 
  FGameProcess:=run_item(cfg,Item);
 
- SetButtonsState(mdsStarted);
+ if (FGameProcess<>nil) then
+ begin
+  Item.FLock:=True;
+  FGameItem:=Item;
+
+  SetButtonsState(mdsStarted);
+ end;
 end;
 
 procedure TfrmMain.TBPlayClick(Sender: TObject);
@@ -571,6 +613,12 @@ begin
   SetButtonsState(mbsStopped);
   FreeAndNil(FGameProcess);
   //
+  if (FGameItem<>nil) then
+  begin
+   FGameItem.FLock:=False;
+   FGameItem:=nil;
+  end;
+  //
   CloseMainWindows;
   //
   Pages.ActivePage:=TabList;

rtl/ntapi.pas

@@ -94,7 +94,8 @@ const
  ProcessImageFileNameWin32=43;
 
  //SystemInformationClass
- SystemTimeAdjustmentInformation=28;
+ SystemTimeAdjustmentInformation      =28;
+ SystemHypervisorSharedPageInformation=197;
 
  //ntapi PriorityClass
  PROCESS_PRIORITY_CLASS_UNKNOWN     =0;

sys/dev/display_soft.pas

@@ -6,6 +6,7 @@ interface
 
 uses
  display_interface,
+ time,
  md_time;
 
 type
@@ -51,8 +52,6 @@ begin
  hWindow:=p_proc.p_host_ipc.OpenMainWindows();
 
  Writeln('OpenMainWindows:',hWindow);
-
- SetWindowTextA(hWindow,'OpenMainWindows');
 end;
 
 function TDisplayHandleSoft.RegisterBufferAttribute(attrid:Byte;attr:p_register_buffer_attr):Integer;
@@ -102,6 +101,10 @@ begin
  ReleaseDC(hWindow, hdc);
 end;
 
+var
+ Ffps     :QWORD=0;
+ Ftsc_prev:QWORD=0;
+
 function TDisplayHandleSoft.SubmitFlip(submit:p_submit_flip):Integer;
 var
  buf:p_buffer;
@@ -121,6 +124,21 @@ begin
  last_status.tsc        :=rdtsc;
  last_status.processTime:=last_status.tsc;
 
+ if (Ftsc_prev=0) then
+ begin
+  Ftsc_prev:=last_status.tsc;
+  Ffps:=1;
+ end else
+ begin
+  Inc(Ffps);
+  if ((last_status.tsc-Ftsc_prev) div tsc_freq)>=1 then
+  begin
+   p_proc.p_host_ipc.SetCaptionFPS(Ffps);
+   Ffps:=0;
+   Ftsc_prev:=last_status.tsc;
+  end;
+ end;
+
  Result:=0;
 end;
 

sys/host_ipc.pas

@@ -20,7 +20,8 @@ type
   iKEV_CHANGE,
   iKEV_EVENT,
   iMOUNT,
-  iMAIN_WINDOWS
+  iMAIN_WINDOWS,
+  iCAPTION_FPS
  );
 
  PNodeHeader=^TNodeHeader;
@@ -71,6 +72,7 @@ type
    //
    procedure   kevent(kev:p_kevent;count:Integer);
    function    OpenMainWindows():THandle;
+   procedure   SetCaptionFps(Ffps:QWORD);
    //
    function    SendSync(mtype:t_mtype;mlen:DWORD;buf:Pointer):Ptruint;
    procedure   SendAsyn(mtype:t_mtype;mlen:DWORD;buf:Pointer);
@@ -296,6 +298,11 @@ begin
  Result:=THandle(SendSync(iMAIN_WINDOWS,0,nil));
 end;
 
+procedure THostIpcConnect.SetCaptionFps(Ffps:QWORD);
+begin
+ SendAsyn(iCAPTION_FPS,SizeOf(Ffps),@Ffps);
+end;
+
 //
 
 function THostIpcConnect.NewNodeSync:PNodeIpcSync;

sys/kern/kern_time.pas

@@ -39,7 +39,7 @@ Procedure timeinit;
 begin
  md_timeinit;
  getmicrouptime(@boottime);
- tsc_freq:=tsc_calibrate;
+ tsc_freq:=get_rdtsc_freq;
 end;
 
 procedure getmicrouptime(tvp:p_timeval);

sys/md/md_time.pas

@@ -13,7 +13,7 @@ uses
 Procedure md_timeinit;
 
 function  rdtsc:QWORD; assembler;
-function  tsc_calibrate:QWORD;
+function  get_rdtsc_freq:QWORD;
 
 function  get_proc_time:Int64;
 function  get_proc_time_freq:Int64;
@@ -46,15 +46,34 @@ end;
 
 function rdtsc:QWORD; assembler; nostackframe;
 asm
+ lfence
  rdtsc
- shl $0x20,%rdx
+ lfence
+ shl  $32,%rdx
  or  %rdx,%rax
 end;
 
+function _get_rdtsc_freq:QWORD;
+var
+ shared_page:PQWORD;
+ size:DWORD;
+ R:DWORD;
+begin
+ Result:=0;
+ shared_page:=nil;
+ size:=0;
+
+ R:=NtQuerySystemInformation(SystemHypervisorSharedPageInformation,
+                             @shared_page,SizeOf(Pointer),@size);
+ if (R<>0) then Exit;
+ if (size<>SizeOf(Pointer)) then Exit;
+
+ Result:=(UNIT_PER_SEC shl 32) div (shared_page[1] shr 32);
+end;
 
 function tsc_calibrate:QWORD;
 const
- samples=40;
+ samples=80;
 var
  i:Integer;
 
@@ -86,6 +105,16 @@ begin
  Result:=tsc_freq;
 end;
 
+function get_rdtsc_freq:QWORD;
+begin
+ Result:=_get_rdtsc_freq;
+
+ if (Result=0) then
+ begin
+  Result:=tsc_calibrate;
+ end;
+end;
+
 function get_proc_time:Int64;
 var
  pc:QWORD;