From 4ee52a2522ef0d40cf260d3e6883925ecf6a48ed Mon Sep 17 00:00:00 2001 From: Olly Date: Mon, 2 Sep 2024 02:53:16 +0100 Subject: [PATCH] dev --- DocGen/docgen.simba | 1 - Source/ide/simba.ide_editor_paramhint.pas | 4 +- .../imports/lcl/simba.import_lcl_form.pas | 191 +-- Source/script/imports/simba.import_async.pas | 143 +- Source/script/imports/simba.import_base.pas | 5 +- .../script/imports/simba.import_threading.pas | 278 ++- Source/simba.base.pas | 2 + Source/simba.fs_async.pas | 12 +- Source/simba.http_async.pas | 153 +- Source/simba.threading.pas | 18 +- Third-Party/numcpulib.pas | 1500 +++++++++++++++++ 11 files changed, 1965 insertions(+), 342 deletions(-) create mode 100644 Third-Party/numcpulib.pas diff --git a/DocGen/docgen.simba b/DocGen/docgen.simba index aede4cfd4..bc48ac051 100644 --- a/DocGen/docgen.simba +++ b/DocGen/docgen.simba @@ -57,7 +57,6 @@ begin APIFiles += ['Source\script\imports\simba.import_image.pas', 'Image' ]; APIFiles += ['Source\script\imports\simba.import_dtm.pas', 'DTM' ]; APIFiles += ['Source\script\imports\simba.import_async.pas', 'ASync' ]; - APIFiles += ['Source\script\imports\simba.import_stringmap.pas', 'String Map' ]; end; procedure H2ToH3(Dir: String); diff --git a/Source/ide/simba.ide_editor_paramhint.pas b/Source/ide/simba.ide_editor_paramhint.pas index 551679529..5a45174d6 100644 --- a/Source/ide/simba.ide_editor_paramhint.pas +++ b/Source/ide/simba.ide_editor_paramhint.pas @@ -514,8 +514,8 @@ procedure TSimbaParamHint.DoEditorCommand(Sender: TObject; AfterProcessing: Bool if (Length(Decls) > 0) then begin - if (Decl is TDeclaration_Method) then - FDisplayPoint.X := FDisplayPoint.X - Length(Decl.Name); + if (Decls[0] is TDeclaration_Method) and (Length(Decls[0].Name) > 0) then + FDisplayPoint.X := FDisplayPoint.X - Length(Decls[0].Name); FHintForm.Font := Font; FHintForm.Font.Color := Editor.Highlighter.IdentifierAttribute.Foreground; diff --git a/Source/script/imports/lcl/simba.import_lcl_form.pas b/Source/script/imports/lcl/simba.import_lcl_form.pas index 4dd66d24f..164c3d73c 100644 --- a/Source/script/imports/lcl/simba.import_lcl_form.pas +++ b/Source/script/imports/lcl/simba.import_lcl_form.pas @@ -121,8 +121,14 @@ procedure _LapeCustomForm_CloseQuery(const Params: PParamArray; const Result: Po end; procedure _LapeCustomForm_EnsureVisible(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV + + procedure Execute; + begin + PCustomForm(Params^[0])^.EnsureVisible(PBoolean(Params^[1])^); + end; + begin - PCustomForm(Params^[0])^.EnsureVisible(PBoolean(Params^[1])^); + RunInMainThread(@Execute); end; procedure _LapeCustomForm_FocusControl(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV @@ -177,23 +183,36 @@ procedure _LapeCustomForm_StayOnTop_Write(const Params: PParamArray); LAPE_WRAPP end; procedure _LapeCustomForm_Show(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV + + procedure Execute; + begin + PCustomForm(Params^[0])^.Show(); + end; + begin - PCustomForm(Params^[0])^.Show(); + RunInMainThread(@Execute); end; procedure _LapeCustomForm_ShowModal(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV + + procedure Execute; + begin + PInteger(Result)^ := PCustomForm(Params^[0])^.ShowModal(); + end; + begin - PInteger(Result)^ := PCustomForm(Params^[0])^.ShowModal(); + RunInMainThread(@Execute); end; procedure _LapeCustomForm_ShowOnTop(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV -begin - PCustomForm(Params^[0])^.ShowOnTop(); -end; -procedure _LapeCustomForm_ProcessMessages(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV + procedure Execute; + begin + PCustomForm(Params^[0])^.ShowOnTop(); + end; + begin - Application.ProcessMessages(); + RunInMainThread(@Execute); end; procedure _LapeCustomForm_Active_Read(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV @@ -343,13 +362,30 @@ procedure _LapeCustomForm_ShowInTaskBar_Write(const Params: PParamArray); LAPE_W procedure _LapeForm_Create(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV begin - if not IsMainThread() then - SimbaException('Forms must be created and run on the main thread, use RunInMainThread'); - PForm(Result)^ := TForm.CreateNew(PComponent(Params^[0])^); PForm(Result)^.ShowInTaskBar := stAlways; end; +procedure _LapeFormThread_Run(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV +begin + RunInMainThread(TThreadMethod(Params^[0]^)); +end; + +procedure _LapeFormThread_Queue(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV +begin + QueueOnMainThread(TThreadMethod(Params^[0]^)); +end; + +procedure _LapeFormThread_IsCurrentThread(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV +begin + PBoolean(Result)^ := IsMainThread(); +end; + +procedure _LapeFormThread_ProcessMessages(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV +begin + Application.ProcessMessages(); +end; + procedure _LapeForm_SaveSession(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV function ArrToSessionProperties(const Arr: TStringArray): String; @@ -396,41 +432,6 @@ procedure _LapeForm_RestoreSession(const Params: PParamArray); LAPE_WRAPPER_CALL end; end; -procedure _LapeForm_Show(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV -begin - PForm(Params^[0])^.Show(); -end; - -procedure _LapeForm_Close(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV -begin - PForm(Params^[0])^.Close(); -end; - -procedure _LapeForm_Hide(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV -begin - PForm(Params^[0])^.Hide(); -end; - -procedure _LapeForm_ClientWidth_Read(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV -begin - PInteger(Result)^ := PForm(Params^[0])^.ClientWidth; -end; - -procedure _LapeForm_ClientWidth_Write(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV -begin - PForm(Params^[0])^.ClientWidth := PInteger(Params^[1])^; -end; - -procedure _LapeForm_ClientHeight_Read(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV -begin - PInteger(Result)^ := PForm(Params^[0])^.ClientHeight; -end; - -procedure _LapeForm_ClientHeight_Write(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV -begin - PForm(Params^[0])^.ClientHeight := PInteger(Params^[1])^; -end; - procedure _LapeForm_OnActivate_Read(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV begin PNotifyEvent(Result)^ := PForm(Params^[0])^.OnActivate; @@ -641,96 +642,6 @@ procedure _LapeForm_OnResize_Write(const Params: PParamArray); LAPE_WRAPPER_CALL PForm(Params^[0])^.OnResize := PNotifyEvent(Params^[1])^; end; -procedure _LapeForm_Enabled_Read(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV -begin - PBoolean(Result)^ := PForm(Params^[0])^.Enabled; -end; - -procedure _LapeForm_Enabled_Write(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV -begin - PForm(Params^[0])^.Enabled := PBoolean(Params^[1])^; -end; - -procedure _LapeForm_Font_Read(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV -begin - PFont(Result)^ := PForm(Params^[0])^.Font; -end; - -procedure _LapeForm_Font_Write(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV -begin - PForm(Params^[0])^.Font := PFont(Params^[1])^; -end; - -procedure _LapeForm_Visible_Read(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV -begin - PBoolean(Result)^ := PForm(Params^[0])^.Visible; -end; - -procedure _LapeForm_Visible_Write(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV -begin - PForm(Params^[0])^.Visible := PBoolean(Params^[1])^; -end; - -procedure _LapeForm_Canvas_Read(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV -begin - PCanvas(Result)^ := PForm(Params^[0])^.Canvas; -end; - -procedure _LapeForm_Canvas_Write(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV -begin - PForm(Params^[0])^.Canvas := PCanvas(Params^[1])^; -end; - -procedure _LapeForm_Left_Read(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV -begin - PInteger(Result)^ := PForm(Params^[0])^.Left; -end; - -procedure _LapeForm_Left_Write(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV -begin - PForm(Params^[0])^.Left := PInteger(Params^[1])^; -end; - -procedure _LapeForm_Height_Read(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV -begin - PInteger(Result)^ := PForm(Params^[0])^.Height; -end; - -procedure _LapeForm_Height_Write(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV -begin - PForm(Params^[0])^.Height := PInteger(Params^[1])^; -end; - -procedure _LapeForm_Top_Read(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV -begin - PInteger(Result)^ := PForm(Params^[0])^.Top; -end; - -procedure _LapeForm_Top_Write(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV -begin - PForm(Params^[0])^.Top := PInteger(Params^[1])^; -end; - -procedure _LapeForm_Width_Read(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV -begin - PInteger(Result)^ := PForm(Params^[0])^.Width; -end; - -procedure _LapeForm_Width_Write(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV -begin - PForm(Params^[0])^.Width := PInteger(Params^[1])^; -end; - -procedure _LapeForm_Caption_Read(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV -begin - PString(Result)^ := PForm(Params^[0])^.Caption; -end; - -procedure _LapeForm_Caption_Write(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV -begin - PForm(Params^[0])^.Caption := PString(Params^[1])^; -end; - procedure _LapeCustomForm_Position_Read(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV begin PPosition(Result)^ := PCustomForm(Params^[0])^.Position; @@ -1079,7 +990,6 @@ procedure ImportLCLForm(Compiler: TSimbaScript_Compiler); addGlobalFunc('procedure TLazCustomForm.SetRestoredBounds(ALeft, ATop, AWidth, AHeight: Integer);', @_LapeCustomForm_SetRestoredBounds); addGlobalFunc('function TLazCustomForm.ShowModal: Integer;', @_LapeCustomForm_ShowModal); addGlobalFunc('procedure TLazCustomForm.ShowOnTop;', @_LapeCustomForm_ShowOnTop); - addGlobalFunc('procedure TLazCustomForm.ProcessMessages; static;', @_LapeCustomForm_ProcessMessages); addProperty('TLazCustomForm', 'BorderStyle', 'ELazFormBorderStyle', @_LapeCustomForm_Read_BorderStyle, @_LapeCustomForm_Write_BorderStyle); addProperty('TLazCustomForm', 'BorderIcons', 'ELazFormBorderIcons', @_LapeCustomForm_Read_BorderIcons, @_LapeCustomForm_Write_BorderIcons); addProperty('TLazCustomForm', 'Active', 'Boolean', @_LapeCustomForm_Active_Read); @@ -1102,6 +1012,13 @@ procedure ImportLCLForm(Compiler: TSimbaScript_Compiler); addClass('TLazForm', 'TLazCustomForm'); addClassConstructor('TLazForm', '(AOwner: TLazComponent = nil)', @_LapeForm_Create); + + addGlobalType('record end;', 'LazFormThread'); + addGlobalFunc('procedure LazFormThread.Run(Method: TThreadMethod); static', @_LapeFormThread_Run); + addGlobalFunc('procedure LazFormThread.Queue(Method: TThreadMethod); static', @_LapeFormThread_Queue); + addGlobalFunc('function LazFormThread.IsCurrentThread: Boolean; static', @_LapeFormThread_IsCurrentThread); + addGlobalFunc('procedure LazFormThread.ProcessMessages; static', @_LapeFormThread_ProcessMessages); + addGlobalFunc('procedure TLazForm.SaveSession(FileName: String; Things: TStringArray);', @_LapeForm_SaveSession); addGlobalFunc('procedure TLazForm.RestoreSession(FileName: String; Things: TStringArray);', @_LapeForm_RestoreSession); diff --git a/Source/script/imports/simba.import_async.pas b/Source/script/imports/simba.import_async.pas index 6e6099d0e..4fbca39c9 100644 --- a/Source/script/imports/simba.import_async.pas +++ b/Source/script/imports/simba.import_async.pas @@ -20,57 +20,87 @@ implementation ASync ===== Things that run in the background. + +``` +procedure ThisIsCalledWhenFinished(constref Result: TASyncHTTPResult); +begin + WriteLn(Result.Response); + WriteLn(Result.Data); +end; + +begin + ASync.HTTPGet('httpbin.org/get', @ThisIsCalledWhenFinished); + + Sleep(5000); // give some time to complete +end; +``` *) (* -ASyncHTTP.Get +ASync.HTTPGet ------------- -> procedure ASyncHTTP.Get(URL: String; OnFinished: TASyncHTTPFinishedEvent; OnProgress: TASyncHTTPProgressEvent); static; +> procedure ASync.HTTPGet(URL: String; OnFinish: TASyncHTTPFinishEvent; OnProgress: TASyncHTTPProgressEvent = nil); static; *) procedure _LapeASyncHTTP_Get1(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV begin - ASyncHTTP.Get(PString(Params^[0])^, TASyncHTTPFinishedEvent(Params^[1]^), TASyncHTTPProgressEvent(Params^[3]^)); + ASyncHTTP.Get(PString(Params^[0])^, [], TASyncHTTPFinishEvent(Params^[1]^), TASyncHTTPProgressEvent(Params^[3]^)); end; (* -ASyncHTTP.Get +ASync.HTTPGet ------------- -> procedure ASyncHTTP.Get(URL: String; DestFile: String; OnFinished: TASyncHTTPFinishedEvent; OnProgress: TASyncHTTPProgressEvent); static; +> procedure ASync.HTTPGet(URL: String; RequestHeaders: TStringArray; OnFinish: TASyncHTTPFinishEvent; OnProgress: TASyncHTTPProgressEvent = nil); static; *) procedure _LapeASyncHTTP_Get2(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV begin - ASyncHTTP.Get(PString(Params^[0])^, PString(Params^[1])^, TASyncHTTPFinishedEvent(Params^[2]^), TASyncHTTPProgressEvent(Params^[3]^)); + ASyncHTTP.Get(PString(Params^[0])^, PStringArray(Params^[1])^, TASyncHTTPFinishEvent(Params^[2]^), TASyncHTTPProgressEvent(Params^[3]^)); end; -procedure _LapeASyncHTTP_GetZip(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV +(* +ASync.HTTPGetFile +----------------- +> procedure ASync.HTTPGetFile(URL: String; DestFile: String; OnFinish: TASyncHTTPFinishEvent; OnProgress: TASyncHTTPProgressEvent = nil); static; +*) +procedure _LapeASyncHTTP_GetFile1(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV begin - ASyncHTTP.GetZip(PString(Params^[0])^, PString(Params^[1])^, TASyncHTTPFinishedEvent(Params^[2]^), TASyncHTTPProgressEvent(Params^[3]^)); + ASyncHTTP.GetFile(PString(Params^[0])^, [], PString(Params^[1])^, TASyncHTTPFinishEvent(Params^[2]^), TASyncHTTPProgressEvent(Params^[3]^)); end; (* -ASyncHTTP.Post -------------- -> procedure ASyncHTTP.Post(URL, PostData: String; OnFinished: TASyncHTTPFinishedEvent); static; +ASync.HTTPGetFile +----------------- +> procedure ASync.HTTPGetFile(URL: String; RequestHeaders: TStringArray; DestFile: String; OnFinish: TASyncHTTPFinishEvent; OnProgress: TASyncHTTPProgressEvent = nil); static; +*) +procedure _LapeASyncHTTP_GetFile2(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV +begin + ASyncHTTP.GetFile(PString(Params^[0])^, PStringArray(Params^[1])^, PString(Params^[2])^,TASyncHTTPFinishEvent(Params^[3]^), TASyncHTTPProgressEvent(Params^[4]^)); +end; + + +(* +ASync.HTTPPost +-------------- +> procedure ASync.HTTPPost(URL, Data: String; OnFinish: TASyncHTTPFinishEvent); static; *) procedure _LapeASyncHTTP_Post1(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV begin - ASyncHTTP.Post(PString(Params^[0])^, PString(Params^[1])^, TASyncHTTPFinishedEvent(Params^[2]^)); + ASyncHTTP.Post(PString(Params^[0])^, [], PString(Params^[1])^, TASyncHTTPFinishEvent(Params^[2]^)); end; (* -ASyncHTTP.Post -------------- -> procedure ASyncHTTP.Post(URL, PostData: String; Headers: TStringArray; OnFinished: TASyncHTTPFinishedEvent); static; +ASync.HTTPPost +-------------- +> procedure ASync.HTTPPost(URL: String; RequestHeaders: TStringArray; Data: String; RequestHeaders: TStringArray; OnFinish: TASyncHTTPFinishEvent); static; *) procedure _LapeASyncHTTP_Post2(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV begin - ASyncHTTP.Post(PString(Params^[0])^, PString(Params^[1])^, PStringArray(Params^[2])^, TASyncHTTPFinishedEvent(Params^[3]^)); + ASyncHTTP.Post(PString(Params^[0])^, PStringArray(Params^[1])^, PString(Params^[2])^, TASyncHTTPFinishEvent(Params^[3]^)); end; (* -ASyncMouse.Move +ASync.MouseMove --------------- -> procedure ASyncMouse.Move(Target: TTarget; Dest: TPoint; Accuracy: Double = 1); +> procedure ASync.MouseMove(Target: TTarget; Dest: TPoint; Accuracy: Double = 1); *) procedure _LapeASyncMouse_Move(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV begin @@ -78,19 +108,19 @@ procedure _LapeASyncMouse_Move(const Params: PParamArray); LAPE_WRAPPER_CALLING_ end; (* -ASyncMouse.ChangeDest +ASync.MouseChangeDest --------------------- -> procedure TASyncMouse.ChangeDest(Dest: TPoint); +> procedure ASync.MouseChangeDest(Dest: TPoint); *) -procedure _LapeASyncMouse_ChangeDest(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV +procedure _LapeASyncMouse_MouseChangeDest(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV begin ASyncMouse.ChangeDest(PPoint(Params^[0])^); end; (* -ASyncMouse.IsMoving -------------------- -> function TASyncMouse.IsMoving: Boolean; +ASync.MouseMoving +----------------- +> function ASync.MouseMoving: Boolean; *) procedure _LapeASyncMouse_IsMoving(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV begin @@ -98,9 +128,9 @@ procedure _LapeASyncMouse_IsMoving(const Params: PParamArray; const Result: Poin end; (* -ASyncMouse.WaitMoving +ASync.MouseWaitMoving --------------------- -> procedure TASyncMouse.WaitMoving; +> procedure ASync.MouseWaitMoving; *) procedure _LapeASyncMouse_WaitMoving(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV begin @@ -108,9 +138,9 @@ procedure _LapeASyncMouse_WaitMoving(const Params: PParamArray); LAPE_WRAPPER_CA end; (* -ASyncMouse.Stop +ASync.MouseStop --------------- -> procedure TASyncMouse.Stop; +> procedure ASync.MouseStop; *) procedure _LapeASyncMouse_Stop(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV begin @@ -118,37 +148,34 @@ procedure _LapeASyncMouse_Stop(const Params: PParamArray); LAPE_WRAPPER_CALLING_ end; (* -ASyncUnZip.Unzip ----------------- -> procedure ASyncUnZip.Unzip(ZipFile, DestPath: String; OnFinished: TASyncUnzipFinishedEvent; OnProgress: TASyncUnzipProgressEvent = nil); static; +ASync.FileUnzip +--------------- +> procedure ASync.FileUnzip(ZipFile, DestPath: String; OnFinish: TASyncUnzipFinishEvent; OnProgress: TASyncUnzipProgressEvent = nil); static; *) procedure _LapeASyncUnZip_Unzip(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV begin - ASyncUnzip.Unzip(PString(Params^[0])^, PString(Params^[1])^, TASyncUnzipFinishedEvent(Params^[2]^), TASyncUnzipProgressEvent(Params^[3]^)); + ASyncUnzip.Unzip(PString(Params^[0])^, PString(Params^[1])^, TASyncUnzipFinishEvent(Params^[2]^), TASyncUnzipProgressEvent(Params^[3]^)); end; procedure ImportASync(Compiler: TSimbaScript_Compiler); begin with Compiler do begin - // Empty "namespaces" - addGlobalType('record end;', 'ASyncMouse'); - addGlobalType('record end;', 'ASyncHTTPClient'); - addGlobalType('record end;', 'ASyncUnZip'); - ImportingSection := 'ASync'; - addGlobalFunc('procedure ASyncMouse.Move(constref Target: TTarget; Dest: TPoint; Accuracy: Double = 1); static; overload;', @_LapeASyncMouse_Move); - addGlobalFunc('procedure ASyncMouse.ChangeDest(Dest: TPoint); static;', @_LapeASyncMouse_ChangeDest); - addGlobalFunc('function ASyncMouse.IsMoving: Boolean; static;', @_LapeASyncMouse_IsMoving); - addGlobalFunc('procedure ASyncMouse.WaitMoving; static;', @_LapeASyncMouse_WaitMoving); - addGlobalFunc('procedure ASyncMouse.Stop; static;', @_LapeASyncMouse_Stop); - - addGlobalFunc( - 'procedure ASyncMouse.Move(Dest: TPoint; Accuracy: Double = 1); static; overload;', [ - 'begin', - ' ASyncMouse.Move(System.Target, Dest, Accuracy);', - 'end;' - ]); + + // namespace + addGlobalType('record end;', 'ASync'); + + addGlobalFunc('procedure ASync.MouseMove(constref Target: TTarget; Dest: TPoint; Accuracy: Double = 1); static; overload;', @_LapeASyncMouse_Move); + addGlobalFunc('procedure ASync.MouseMove(Dest: TPoint; Accuracy: Double = 1); static; overload;', [ + 'begin', + ' ASync.MouseMove(System.Target, Dest, Accuracy);', + 'end;' + ]); + addGlobalFunc('procedure ASync.MouseChangeDest(Dest: TPoint); static;', @_LapeASyncMouse_MouseChangeDest); + addGlobalFunc('function ASync.MouseMoving: Boolean; static;', @_LapeASyncMouse_IsMoving); + addGlobalFunc('procedure ASync.MouseWaitMoving; static;', @_LapeASyncMouse_WaitMoving); + addGlobalFunc('procedure ASync.MouseStop; static;', @_LapeASyncMouse_Stop); addGlobalType([ 'record', @@ -161,13 +188,15 @@ procedure ImportASync(Compiler: TSimbaScript_Compiler); 'end;'], 'TASyncHTTPResult'); - addGlobalType('procedure(constref Result: TASyncHTTPResult) of object', 'TASyncHTTPFinishedEvent', FFI_DEFAULT_ABI); + addGlobalType('procedure(constref Result: TASyncHTTPResult) of object', 'TASyncHTTPFinishEvent', FFI_DEFAULT_ABI); addGlobalType('procedure(URL: String; Position, Size: Int64) of object', 'TASyncHTTPProgressEvent', FFI_DEFAULT_ABI); - addGlobalFunc('procedure ASyncHTTPClient.Get(URL: String; OnFetched: TASyncHTTPFinishedEvent; OnProgress: TASyncHTTPProgressEvent = nil); static; overload;', @_LapeASyncHTTP_Get1); - addGlobalFunc('procedure ASyncHTTPClient.Get(URL, DestFile: String; OnFetched: TASyncHTTPFinishedEvent; OnProgress: TASyncHTTPProgressEvent = nil); static; overload;', @_LapeASyncHTTP_Get2); - addGlobalFunc('procedure ASyncHTTPClient.GetZip(URL, DestFile: String; OnFinished: TASyncHTTPFinishedEvent; OnProgress: TASyncHTTPProgressEvent = nil); static;', @_LapeASyncHTTP_GetZip); - addGlobalFunc('procedure ASyncHTTPClient.Post(URL, PostData: String); static; overload;', @_LapeASyncHTTP_Post1); - addGlobalFunc('procedure ASyncHTTPClient.Post(URL, PostData: String; Headers: TStringArray); static; overload;', @_LapeASyncHTTP_Post2); + + addGlobalFunc('procedure ASync.HTTPGet(URL: String; OnFinish: TASyncHTTPFinishEvent; OnProgress: TASyncHTTPProgressEvent = nil); static; overload;', @_LapeASyncHTTP_Get1); + addGlobalFunc('procedure ASync.HTTPGet(URL: String; RequestHeaders: TStringArray; OnFinish: TASyncHTTPFinishEvent; OnProgress: TASyncHTTPProgressEvent = nil); static; overload;', @_LapeASyncHTTP_Get2); + addGlobalFunc('procedure ASync.HTTPGetFile(URL: String; DestFile: String; OnFinish: TASyncHTTPFinishEvent; OnProgress: TASyncHTTPProgressEvent = nil); static; overload;', @_LapeASyncHTTP_GetFile1); + addGlobalFunc('procedure ASync.HTTPGetFile(URL: String; RequestHeaders: TStringArray; DestFile: String; OnFinish: TASyncHTTPFinishEvent; OnProgress: TASyncHTTPProgressEvent = nil); static; overload;', @_LapeASyncHTTP_GetFile2); + addGlobalFunc('procedure ASync.HTTPPost(URL, Data: String; OnFinish: TASyncHTTPFinishEvent = nil); static; overload;', @_LapeASyncHTTP_Post1); + addGlobalFunc('procedure ASync.HTTPPost(URL: String; RequestHeaders: TStringArray; Data: String; OnFinish: TASyncHTTPFinishEvent = nil); static; overload;', @_LapeASyncHTTP_Post2); addGlobalType([ 'record', @@ -179,10 +208,10 @@ procedure ImportASync(Compiler: TSimbaScript_Compiler); 'end;'], 'TASyncUnzipResult'); - addGlobalType('procedure(constref Result: TASyncUnzipResult) of object', 'TASyncUnzipFinishedEvent', FFI_DEFAULT_ABI); + addGlobalType('procedure(constref Result: TASyncUnzipResult) of object', 'TASyncUnzipFinishEvent', FFI_DEFAULT_ABI); addGlobalType('procedure(Position, Total: Int64) of object', 'TASyncUnzipProgressEvent', FFI_DEFAULT_ABI); - addGlobalFunc('procedure ASyncUnZip.Unzip(ZipFile, DestPath: String; OnFinished: TASyncUnzipFinishedEvent; OnProgress: TASyncUnzipProgressEvent = nil); static;', @_LapeASyncUnZip_Unzip); + addGlobalFunc('procedure ASync.FileUnZip(ZipFile, DestPath: String; OnFinish: TASyncUnzipFinishEvent; OnProgress: TASyncUnzipProgressEvent = nil); static;', @_LapeASyncUnZip_Unzip); ImportingSection := ''; end; diff --git a/Source/script/imports/simba.import_base.pas b/Source/script/imports/simba.import_base.pas index 579e2cb56..2372ce40c 100644 --- a/Source/script/imports/simba.import_base.pas +++ b/Source/script/imports/simba.import_base.pas @@ -14,7 +14,7 @@ implementation uses Graphics, Variants, - lptypes, lpvartypes, lpparser, + lptypes, lpvartypes, lpparser, ffi, simba.nativeinterface, simba.env, simba.baseclass, simba.vartype_ordarray; (* @@ -511,6 +511,9 @@ procedure ImportBase(Compiler: TSimbaScript_Compiler); addGlobalFunc('function TByteArray.ToString: String;', @_LapeByteArray_ToString); addGlobalFunc('procedure TByteArray.FromString(Str: String);', @_LapeByteArray_FromString); + addGlobalType('procedure() of object', 'TThreadMethod', FFI_DEFAULT_ABI); + addGlobalType('procedure(Args: array of Pointer) of object', 'TThreadMethodEx', FFI_DEFAULT_ABI); + ImportingSection := ''; addClass('TBaseClass', 'Pointer'); diff --git a/Source/script/imports/simba.import_threading.pas b/Source/script/imports/simba.import_threading.pas index c709472b9..e71d67d9b 100644 --- a/Source/script/imports/simba.import_threading.pas +++ b/Source/script/imports/simba.import_threading.pas @@ -11,39 +11,229 @@ interface uses Classes, SysUtils, - simba.base, simba.script_compiler; + simba.base, simba.script_compiler, simba.threading; procedure ImportThreading(Compiler: TSimbaScript_Compiler); implementation uses - lptypes, lpparser, ffi, - simba.threading; + syncobjs, + lptypes, lpvartypes, lpinterpreter; -procedure _LapeCurrentThreadID(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV +type + PSimbaLock = ^TSimbaLock; + TSimbaLock = class(TObject) + protected + FCriticalSection: TCriticalSection; + public + constructor Create; reintroduce; + destructor Destroy; override; + + function TryEnter: Boolean; + procedure Enter; + procedure Leave; + end; + +constructor TSimbaLock.Create; begin - TThreadID(Result^) := GetCurrentThreadID(); + inherited Create(); + + FCriticalSection := TCriticalSection.Create(); end; -procedure _LapeMainThreadID(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV +destructor TSimbaLock.Destroy; begin - TThreadID(Result^) := MainThreadID; + FreeAndNil(FCriticalSection); + + inherited Destroy(); end; -procedure _LapeQueueInMainThread(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV +function TSimbaLock.TryEnter: Boolean; begin - QueueOnMainThread(TThreadMethod(Params^[0]^)); + Result := FCriticalSection.TryEnter(); end; -procedure _LapeRunInMainThread(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV +procedure TSimbaLock.Enter; begin - RunInMainThread(TThreadMethod(Params^[0]^)); + FCriticalSection.Enter(); end; -procedure _LapeRunInThread(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV +procedure TSimbaLock.Leave; begin - RunInThread(TThreadMethod(Params^[0]^), True); + FCriticalSection.Leave(); +end; + +type + PSimbaThread = ^TSimbaThread; + TSimbaThread = class(TThread) + protected + FCodeRunner: TLapeCodeRunner; + FMethod: TMethod; + FOnTerminateMethod: TMethod; + FName: String; + + procedure DoTerminate; override; + procedure Execute; override; + + procedure InvokeScriptMethod(Method: TMethod); + + function GetName: String; + procedure SetName(Value: String); + public + constructor Create(Emitter: TLapeCodeEmitter; Method, OnTerminateMethod: TMethod); reintroduce; + constructor CreateAnon(Emitter: TLapeCodeEmitter; Method, OnTerminateMethod: TMethod); reintroduce; + destructor Destroy; override; + + function WaitForTerminate(Timeout: Int32): Boolean; + + property Name: String read GetName write SetName; + end; + +procedure TSimbaThread.InvokeScriptMethod(Method: TMethod); +var + VarStack: array[0..SizeOf(Pointer) - 1] of Byte; +begin + PPointer(@VarStack[0])^ := Method.Data; + + FCodeRunner.Run(TCodePos(Method.Code), VarStack); +end; + +procedure TSimbaThread.DoTerminate; +begin + if (FOnTerminateMethod.Code <> nil) then + InvokeScriptMethod(FOnTerminateMethod); +end; + +procedure TSimbaThread.Execute; +begin + if (FMethod.Code <> nil) then + InvokeScriptMethod(FMethod); +end; + +function TSimbaThread.GetName: String; +begin + Result := FName; +end; + +procedure TSimbaThread.SetName(Value: String); +begin + FName := Value; + NameThreadForDebugging(FName, ThreadID); +end; + +constructor TSimbaThread.Create(Emitter: TLapeCodeEmitter; Method, OnTerminateMethod: TMethod); +begin + inherited Create(False); + + FCodeRunner := TLapeCodeRunner.Create(Emitter); + FMethod := Method; + FOnTerminateMethod := OnTerminateMethod; +end; + +constructor TSimbaThread.CreateAnon(Emitter: TLapeCodeEmitter; Method, OnTerminateMethod: TMethod); +begin + FreeOnTerminate := True; + + Create(Emitter, Method, OnTerminateMethod); +end; + +destructor TSimbaThread.Destroy; +begin + FreeAndNil(FCodeRunner); + + inherited Destroy(); +end; + +function TSimbaThread.WaitForTerminate(Timeout: Int32): Boolean; +begin + Result := WaitForThreadTerminate(ThreadID, Timeout) = 0; +end; + +procedure _LapeCreateThread(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV +begin + PPointer(Result)^ := TSimbaThread.Create(TLapeCodeEmitter(Params^[2]^), PMethod(Params^[0])^, PMethod(Params^[1])^); +end; + +procedure _LapeCreateThreadAnon(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV +begin + PPointer(Result)^ := TSimbaThread.CreateAnon(TLapeCodeEmitter(Params^[2]^), PMethod(Params^[0])^, PMethod(Params^[1])^); +end; + +procedure _LapeThread_Name_Read(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV +begin + PString(Result)^ := PSimbaThread(Params^[0])^.Name; +end; + +procedure _LapeThread_Name_Write(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV +begin + PSimbaThread(Params^[0])^.Name := PString(Params^[1])^; +end; + +procedure _LapeThread_Running_Read(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV +begin + PBoolean(Result)^ := not PSimbaThread(Params^[0])^.Finished; +end; + +procedure _LapeThread_ThreadID_Read(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV +begin + PUInt64(Result)^ := PSimbaThread(Params^[0])^.ThreadID; +end; + +procedure _LapeThread_FatalException_Read(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV +begin + with PSimbaThread(Params^[0])^ do + begin + if (FatalException is Exception) then + PString(Result)^ := Exception(FatalException).Message + else + PString(Result)^ := ''; + end; +end; + +procedure _LapeThread_Terminate(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV +begin + PSimbaThread(Params^[0])^.Terminate(); +end; + +procedure _LapeThread_WaitForTerminate1(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV +begin + PSimbaThread(Params^[0])^.WaitFor(); +end; + +procedure _LapeThread_WaitForTerminate2(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV +begin + PBoolean(Result)^ := PSimbaThread(Params^[0])^.WaitForTerminate(PInteger(Params^[1])^); +end; + +procedure _LapeThread_Free(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV +begin + PSimbaThread(Params^[0])^.Free(); +end; + +procedure _LapeLock_Create(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV +begin + PSimbaLock(Result)^ := TSimbaLock.Create(); +end; + +procedure _LapeLock_TryEnter(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV +begin + PBoolean(Result)^ := PSimbaLock(Params^[0])^.TryEnter(); +end; + +procedure _LapeLock_Enter(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV +begin + PSimbaLock(Params^[0])^.Enter(); +end; + +procedure _LapeLock_Leave(const Params: PParamArray); LAPE_WRAPPER_CALLING_CONV +begin + PSimbaLock(Params^[0])^.Leave(); +end; + +procedure _LapeCurrentThreadID(const Params: PParamArray; const Result: Pointer); LAPE_WRAPPER_CALLING_CONV +begin + PUInt64(Result)^ := GetCurrentThreadID(); end; procedure ImportThreading(Compiler: TSimbaScript_Compiler); @@ -52,17 +242,63 @@ procedure ImportThreading(Compiler: TSimbaScript_Compiler); begin ImportingSection := 'Threading'; - addGlobalVar(CPUCount, 'CPU_COUNT').isConstant := True; + addGlobalVar( + 'record' + LineEnding + + ' CoreCount: Int32;' + LineEnding + + ' ThreadCount: Int32;' + LineEnding + + ' PhysicalMemory: Int32;' + LineEnding + + 'end;', + @SimbaCPUInfo, + 'CPUInfo' + ).isConstant := True; + + addGlobalFunc('function _CreateThread(Method: procedure of object; OnTerminateMethod: procedure of object = nil; Emitter: Pointer = Pointer(' + IntToStr(PtrUInt(Emitter)) + ')): Pointer; overload;', @_LapeCreateThread); + addGlobalFunc('function _CreateThreadAnon(Method: procedure of object; OnTerminateMethod: procedure of object = nil; Emitter: Pointer = Pointer(' + IntToStr(PtrUInt(Emitter)) + ')): Pointer; overload;', @_LapeCreateThreadAnon); + + addGlobalType('strict Pointer', 'TThread'); + addGlobalFunc('property TThread.Name: String', @_LapeThread_Name_Read); + addGlobalFunc('property TThread.Name(Value: String)', @_LapeThread_Name_Write); + addGlobalFunc('property TThread.Running: Boolean', @_LapeThread_Running_Read); + addGlobalFunc('property TThread.ThreadID: UInt64', @_LapeThread_ThreadID_Read); + addGlobalFunc('property TThread.FatalException: String', @_LapeThread_FatalException_Read); + addGlobalFunc('procedure TThread.Terminate;', @_LapeThread_Terminate); + addGlobalFunc('procedure TThread.WaitForTerminate; overload', @_LapeThread_WaitForTerminate1); + addGlobalFunc('function TThread.WaitForTerminate(Timeout: Int32): Boolean; overload', @_LapeThread_WaitForTerminate2); + addGlobalFunc('procedure TThread.Free;', @_LapeThread_Free); - addGlobalType(getBaseType(DetermineIntType(SizeOf(TThreadID), False)).createCopy(), 'TThreadID'); - addGlobalType('procedure() of object', 'TThreadMethod', FFI_DEFAULT_ABI); + addDelayedCode( + 'function TThread.Create(Method: procedure of object): TThread; static; overload;' + LineEnding + + 'begin' + LineEnding + + ' if (not IsScriptMethod(@Method)) then' + LineEnding + + ' raise "Script method expected";' + LineEnding + + ' Result := TThread(_CreateThread(@Method));' + LineEnding + + 'end;' + LineEnding + + '' + LineEnding + + 'function TThread.Create(Method, OnTerminateMethod: procedure of object): TThread; static; overload;' + LineEnding + + 'begin' + LineEnding + + ' if (not IsScriptMethod(@Method)) or (not IsScriptMethod(@OnTerminateMethod)) then' + LineEnding + + ' raise "Script method expected";' + LineEnding + + ' Result := TThread(_CreateThread(@Method, @OnTerminateMethod));' + LineEnding + + 'end;' + LineEnding + + '' + LineEnding + + 'procedure RunInThread(Method: procedure of object); overload;' + LineEnding + + 'begin' + LineEnding + + ' _CreateThreadAnon(@Method);' + LineEnding + + 'end;' + LineEnding + + '' + LineEnding + + 'procedure RunInThread(Method, OnTerminateMethod: procedure of object); overload;' + LineEnding + + 'begin' + LineEnding + + ' _CreateThreadAnon(@Method, @OnTerminateMethod);' + LineEnding + + 'end;' + ); - addGlobalFunc('function CurrentThreadID: TThreadID', @_LapeCurrentThreadID); - addGlobalFunc('function MainThreadID: TThreadID', @_LapeMainThreadID); + addGlobalType('strict Pointer', 'TLock'); + addGlobalFunc('function TLock.Create: TLock; static;', @_LapeLock_Create); + addGlobalFunc('function TLock.TryEnter: Boolean;', @_LapeLock_TryEnter); + addGlobalFunc('procedure TLock.Enter;', @_LapeLock_Enter); + addGlobalFunc('procedure TLock.Leave;', @_LapeLock_Leave); - addGlobalFunc('procedure QueueInMainThread(Method: TThreadMethod)', @_LapeQueueInMainThread); - addGlobalFunc('procedure RunInMainThread(Method: TThreadMethod)', @_LapeRunInMainThread); - addGlobalFunc('procedure RunInThread(Method: TThreadMethod)', @_LapeRunInThread); + addGlobalFunc('function CurrentThreadID: UInt64', @_LapeCurrentThreadID); ImportingSection := ''; end; diff --git a/Source/simba.base.pas b/Source/simba.base.pas index 8ecd724aa..06507a855 100644 --- a/Source/simba.base.pas +++ b/Source/simba.base.pas @@ -265,6 +265,8 @@ TPointF = record X, Y: Double; end; TInt64Array = array of Int64; PInt64Array = ^TInt64Array; + TPointerArray = array of Pointer; + EComparator = (__LT__, __GT__, __EQ__, __LE__, __GE__, __NE__); PComparator = ^EComparator; diff --git a/Source/simba.fs_async.pas b/Source/simba.fs_async.pas index 915aa3767..bd25867e3 100644 --- a/Source/simba.fs_async.pas +++ b/Source/simba.fs_async.pas @@ -21,12 +21,12 @@ TASyncUnzipResult = record Exception: String; TimeUsed: Double; end; - TASyncUnzipFinishedEvent = procedure(constref Result: TASyncUnzipResult) of object; + TASyncUnzipFinishEvent = procedure(constref Result: TASyncUnzipResult) of object; TASyncUnzipProgressEvent = procedure(Position, Total: Int64) of object; ASyncUnzip = class class procedure Unzip(ZipFile, DestPath: String; - OnFinished: TASyncUnzipFinishedEvent; + OnFinished: TASyncUnzipFinishEvent; OnProgress: TASyncUnzipProgressEvent); static; end; @@ -41,16 +41,16 @@ TUnzipInBackground = class(TThread) FZipFile: String; FDestPath: String; FOnProgress: TASyncUnzipProgressEvent; - FOnFinished: TASyncUnzipFinishedEvent; + FOnFinished: TASyncUnzipFinishEvent; procedure DoProgress(Sender: TObject; Const ATotPos, ATotSize: Int64); procedure Execute; override; public - constructor Create(ZipFile, DestPath: String; OnProgress: TASyncUnzipProgressEvent; OnFinished: TASyncUnzipFinishedEvent); reintroduce; + constructor Create(ZipFile, DestPath: String; OnProgress: TASyncUnzipProgressEvent; OnFinished: TASyncUnzipFinishEvent); reintroduce; end; -class procedure ASyncUnzip.Unzip(ZipFile, DestPath: String; OnFinished: TASyncUnzipFinishedEvent; OnProgress: TASyncUnzipProgressEvent); +class procedure ASyncUnzip.Unzip(ZipFile, DestPath: String; OnFinished: TASyncUnzipFinishEvent; OnProgress: TASyncUnzipProgressEvent); begin TUnzipInBackground.Create(ZipFile, DestPath, OnProgress, OnFinished); end; @@ -96,7 +96,7 @@ procedure TUnzipInBackground.Execute; FOnFinished(Result); end; -constructor TUnzipInBackground.Create(ZipFile, DestPath: String; OnProgress: TASyncUnzipProgressEvent; OnFinished: TASyncUnzipFinishedEvent); +constructor TUnzipInBackground.Create(ZipFile, DestPath: String; OnProgress: TASyncUnzipProgressEvent; OnFinished: TASyncUnzipFinishEvent); begin inherited Create(False, 512*512); diff --git a/Source/simba.http_async.pas b/Source/simba.http_async.pas index b91c894b2..6c7dff131 100644 --- a/Source/simba.http_async.pas +++ b/Source/simba.http_async.pas @@ -22,15 +22,13 @@ TASyncHTTPResult = record Exception: String; TimeUsed: Double; end; - TASyncHTTPFinishedEvent = procedure(constref Result: TASyncHTTPResult) of object; + TASyncHTTPFinishEvent = procedure(constref Result: TASyncHTTPResult) of object; TASyncHTTPProgressEvent = procedure(URL: String; Position, Size: Int64) of object; ASyncHTTP = class - class procedure Get(URL: String; OnFinished: TASyncHTTPFinishedEvent; OnProgress: TASyncHTTPProgressEvent); static; - class procedure Get(URL: String; DestFile: String; OnFinished: TASyncHTTPFinishedEvent; OnProgress: TASyncHTTPProgressEvent); static; - class procedure GetZip(URL, DestFile: String; OnFinished: TASyncHTTPFinishedEvent; OnProgress: TASyncHTTPProgressEvent); static; - class procedure Post(URL, PostData: String; OnFinished: TASyncHTTPFinishedEvent); static; - class procedure Post(URL, PostData: String; Headers: TStringArray; OnFinished: TASyncHTTPFinishedEvent); static; + class procedure Get(URL: String; RequestHeaders: TStringArray; OnFinish: TASyncHTTPFinishEvent; OnProgress: TASyncHTTPProgressEvent); static; + class procedure Post(URL: String; RequestHeaders: TStringArray; Data: String; OnFinish: TASyncHTTPFinishEvent); static; + class procedure GetFile(URL: String; RequestHeaders: TStringArray; DestFile: String; OnFinish: TASyncHTTPFinishEvent; OnProgress: TASyncHTTPProgressEvent); static; end; implementation @@ -43,102 +41,31 @@ TURLFetchInBackground = class(TThread) protected FURL: String; FDestFile: String; - FOnFinished: TASyncHTTPFinishedEvent; + FRequestHeaders: TStringArray; + FOnFinished: TASyncHTTPFinishEvent; FOnProgress: TASyncHTTPProgressEvent; procedure DoProgress(Sender: TObject; URL, ContentType: String; Position, Size: Int64); procedure Execute; override; public - constructor Create(URL: String; OnFinished: TASyncHTTPFinishedEvent; OnProgress: TASyncHTTPProgressEvent); reintroduce; - constructor Create(URL: String; DestFile: String; OnFinished: TASyncHTTPFinishedEvent; OnProgress: TASyncHTTPProgressEvent); reintroduce; - end; - - TURLFetchZipInBackground = class(TThread) - protected - FURL: String; - FDestFile: String; - FOnFinished: TASyncHTTPFinishedEvent; - FOnProgress: TASyncHTTPProgressEvent; - - procedure DoProgress(Sender: TObject; URL, ContentType: String; Position, Size: Int64); - procedure DoExtract(Sender: TObject; FileName: String; Position, Size: Int64); - - procedure Execute; override; - public - constructor Create(URL, DestFile: String; OnFinished: TASyncHTTPFinishedEvent; OnProgress: TASyncHTTPProgressEvent); reintroduce; + constructor Create(URL: String; RequestHeaders: TStringArray; OnFinish: TASyncHTTPFinishEvent; OnProgress: TASyncHTTPProgressEvent); reintroduce; + constructor Create(URL: String; RequestHeaders: TStringArray; DestFile: String; OnFinish: TASyncHTTPFinishEvent; OnProgress: TASyncHTTPProgressEvent); reintroduce; end; TURLPostInBackground = class(TThread) protected FURL: String; FPostData: String; - FHeaders: TStringArray; - FOnFinished: TASyncHTTPFinishedEvent; + FRequestHeaders: TStringArray; + FOnFinished: TASyncHTTPFinishEvent; procedure Execute; override; public - constructor Create(URL, PostData: String; Headers: TStringArray; OnFinished: TASyncHTTPFinishedEvent); reintroduce; + constructor Create(URL, PostData: String; RequestHeaders: TStringArray; OnFinish: TASyncHTTPFinishEvent); reintroduce; end; -procedure TURLFetchZipInBackground.DoProgress(Sender: TObject; URL, ContentType: String; Position, Size: Int64); -begin - if Assigned(FOnProgress) then - FOnProgress(URL, Position, Size); -end; - -procedure TURLFetchZipInBackground.DoExtract(Sender: TObject; FileName: String; Position, Size: Int64); -begin - if Assigned(FOnProgress) then - FOnProgress('extract', Position, Size); -end; - -procedure TURLFetchZipInBackground.Execute; -var - Result: TASyncHTTPResult; -begin - Result := Default(TASyncHTTPResult); - Result.URL := FURL; - Result.TimeUsed := HighResolutionTime(); - Result.Data := FDestFile; - - try - with TSimbaHTTPClient.Create() do - try - OnDownloadProgress := @DoProgress; - OnExtractProgress := @DoExtract; - - GetZip(FURL, FDestFile, False, []); - - Result.Response := ResponseStatus; - Result.Headers := ResponseHeaders.ToStringArray; - finally - Free(); - end; - except - on E: Exception do - Result.Exception := E.Message; - end; - - Result.TimeUsed := HighResolutionTime() - Result.TimeUsed; - - if Assigned(FOnFinished) then - FOnFinished(Result); -end; - -constructor TURLFetchZipInBackground.Create(URL, DestFile: String; OnFinished: TASyncHTTPFinishedEvent; OnProgress: TASyncHTTPProgressEvent); -begin - inherited Create(False, 512*512); - - FreeOnTerminate := True; - - FURL := URL; - FDestFile := DestFile; - FOnFinished := OnFinished; - FOnProgress := OnProgress; -end; - -constructor TURLPostInBackground.Create(URL, PostData: String; Headers: TStringArray; OnFinished: TASyncHTTPFinishedEvent); +constructor TURLPostInBackground.Create(URL, PostData: String; RequestHeaders: TStringArray; OnFinish: TASyncHTTPFinishEvent); begin inherited Create(False, 512*512); @@ -146,13 +73,14 @@ constructor TURLPostInBackground.Create(URL, PostData: String; Headers: TStringA FURL := URL; FPostData := PostData; - FHeaders := Headers; - FOnFinished := OnFinished; + FRequestHeaders := RequestHeaders; + FOnFinished := OnFinish; end; procedure TURLPostInBackground.Execute; var Result: TASyncHTTPResult; + I: Integer; begin Result := Default(TASyncHTTPResult); Result.URL := FURL; @@ -161,7 +89,12 @@ procedure TURLPostInBackground.Execute; try with TSimbaHTTPClient.Create() do try - RequestHeaders.AddStrings(FHeaders); + I := 0; + while (I < High(FRequestHeaders)) do + begin + RequestHeader[FRequestHeaders[i]] := FRequestHeaders[i+1]; + I += 2; + end; Result.Data := Post(FURL, FPostData); Result.Response := ResponseStatus; @@ -180,29 +113,19 @@ procedure TURLPostInBackground.Execute; FOnFinished(Result); end; -class procedure ASyncHTTP.Get(URL: String; OnFinished: TASyncHTTPFinishedEvent; OnProgress: TASyncHTTPProgressEvent); -begin - TURLFetchInBackground.Create(URL, OnFinished, OnProgress); -end; - -class procedure ASyncHTTP.Get(URL: String; DestFile: String; OnFinished: TASyncHTTPFinishedEvent; OnProgress: TASyncHTTPProgressEvent); -begin - TURLFetchInBackground.Create(URL, DestFile, OnFinished, OnProgress); -end; - -class procedure ASyncHTTP.GetZip(URL, DestFile: String; OnFinished: TASyncHTTPFinishedEvent; OnProgress: TASyncHTTPProgressEvent); +class procedure ASyncHTTP.Get(URL: String; RequestHeaders: TStringArray; OnFinish: TASyncHTTPFinishEvent; OnProgress: TASyncHTTPProgressEvent); begin - TURLFetchZipInBackground.Create(URL, DestFile, OnFinished, OnProgress); + TURLFetchInBackground.Create(URL, RequestHeaders, OnFinish, OnProgress); end; -class procedure ASyncHTTP.Post(URL, PostData: String; OnFinished: TASyncHTTPFinishedEvent); +class procedure ASyncHTTP.GetFile(URL: String; RequestHeaders: TStringArray; DestFile: String; OnFinish: TASyncHTTPFinishEvent; OnProgress: TASyncHTTPProgressEvent); begin - TURLPostInBackground.Create(URL, PostData, [], OnFinished); + TURLFetchInBackground.Create(URL, RequestHeaders, DestFile, OnFinish, OnProgress); end; -class procedure ASyncHTTP.Post(URL, PostData: String; Headers: TStringArray; OnFinished: TASyncHTTPFinishedEvent); +class procedure ASyncHTTP.Post(URL: String; RequestHeaders: TStringArray; Data: String; OnFinish: TASyncHTTPFinishEvent); begin - TURLPostInBackground.Create(URL, PostData, Headers, OnFinished); + TURLPostInBackground.Create(URL, Data, RequestHeaders, OnFinish); end; procedure TURLFetchInBackground.DoProgress(Sender: TObject; URL, ContentType: String; Position, Size: Int64); @@ -214,6 +137,7 @@ procedure TURLFetchInBackground.DoProgress(Sender: TObject; URL, ContentType: St procedure TURLFetchInBackground.Execute; var Result: TASyncHTTPResult; + I: Integer; begin Result := Default(TASyncHTTPResult); Result.URL := FURL; @@ -224,6 +148,13 @@ procedure TURLFetchInBackground.Execute; try OnDownloadProgress := @DoProgress; + I := 0; + while (I < High(FRequestHeaders)) do + begin + RequestHeader[FRequestHeaders[i]] := FRequestHeaders[i+1]; + I += 2; + end; + if (FDestFile <> '') then begin GetFile(FURL, FDestFile); @@ -248,27 +179,23 @@ procedure TURLFetchInBackground.Execute; FOnFinished(Result); end; -constructor TURLFetchInBackground.Create(URL: String; OnFinished: TASyncHTTPFinishedEvent; OnProgress: TASyncHTTPProgressEvent); +constructor TURLFetchInBackground.Create(URL: String; RequestHeaders: TStringArray; OnFinish: TASyncHTTPFinishEvent; OnProgress: TASyncHTTPProgressEvent); begin inherited Create(False, 512*512); FreeOnTerminate := True; FURL := URL; - FOnFinished := OnFinished; + FOnFinished := OnFinish; FOnProgress := OnProgress; + FRequestHeaders := RequestHeaders; end; -constructor TURLFetchInBackground.Create(URL: String; DestFile: String; OnFinished: TASyncHTTPFinishedEvent; OnProgress: TASyncHTTPProgressEvent); +constructor TURLFetchInBackground.Create(URL: String; RequestHeaders: TStringArray; DestFile: String; OnFinish: TASyncHTTPFinishEvent; OnProgress: TASyncHTTPProgressEvent); begin - inherited Create(False, 512*512); - - FreeOnTerminate := True; + Create(URL, RequestHeaders, OnFinish, OnProgress); FDestFile := DestFile; - FURL := URL; - FOnFinished := OnFinished; - FOnProgress := OnProgress; end; end. diff --git a/Source/simba.threading.pas b/Source/simba.threading.pas index e3799094f..5b0bbc158 100644 --- a/Source/simba.threading.pas +++ b/Source/simba.threading.pas @@ -108,8 +108,17 @@ TPoolThread = class(TThread) var SimbaThreadPool: TSimbaThreadPool = nil; + SimbaCPUInfo: record + CoreCount: Integer; + ThreadCount: Integer; + PhysicalMemory: Integer; + end; + implementation +uses + NumCPULib; + procedure TLimit.Inc; begin InterlockedIncrement(FCount); @@ -487,10 +496,11 @@ destructor TSimbaThreadPool.TPoolThread.Destroy; end; initialization - if (TThread.ProcessorCount > 10) then - SimbaThreadPool := TSimbaThreadPool.Create(Round(TThread.ProcessorCount * 0.75)) // dont go crazy if we have >8 cores. - else - SimbaThreadPool := TSimbaThreadPool.Create(TThread.ProcessorCount); + SimbaCPUInfo.ThreadCount := TNumCPULib.GetLogicalCPUCount(); + SimbaCPUInfo.CoreCount := TNumCPULib.GetPhysicalCPUCount(); + SimbaCPUInfo.PhysicalMemory := TNumCPULib.GetTotalPhysicalMemory(); + + SimbaThreadPool := TSimbaThreadPool.Create(SimbaCPUInfo.CoreCount); finalization FreeAndNil(SimbaThreadPool); diff --git a/Third-Party/numcpulib.pas b/Third-Party/numcpulib.pas new file mode 100644 index 000000000..83460e89a --- /dev/null +++ b/Third-Party/numcpulib.pas @@ -0,0 +1,1500 @@ +{ *********************************************************************************** } +{ * NumCPULib Library * } +{ * Copyright (c) 2019 Ugochukwu Mmaduekwe * } +{ * Github Repository * } + +{ * Distributed under the MIT software license, see the accompanying file LICENSE * } +{ * or visit http://www.opensource.org/licenses/mit-license.php. * } + +{ * ******************************************************************************* * } + +(* &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& *) + +unit NumCPULib; + +{$DEFINE DELPHI} + +{$IFDEF FPC} +{$UNDEF DELPHI} +{$MODE DELPHI} + +// Disable Hints. +{$HINTS OFF} + +{$IFDEF CPU386} + {$DEFINE NUMCPULIB_X86} +{$ENDIF} + +{$IFDEF CPUX64} + {$DEFINE NUMCPULIB_X86_64} +{$ENDIF} + +{$IFDEF CPUARM} + {$DEFINE NUMCPULIB_ARM} +{$ENDIF} + +{$IFDEF CPUAARCH64} + {$DEFINE NUMCPULIB_AARCH64} +{$ENDIF} + +{$IF DEFINED(NUMCPULIB_ARM) OR DEFINED(NUMCPULIB_AARCH64)} + {$DEFINE NUMCPULIB_ARMCPU} +{$IFEND} + +{$IFDEF IPHONESIM} + {$DEFINE NUMCPULIB_IOSSIM} +{$ENDIF} + +{$IF DEFINED(MSWINDOWS)} + {$DEFINE NUMCPULIB_MSWINDOWS} +{$ELSEIF DEFINED(UNIX)} + {$DEFINE NUMCPULIB_UNIX} + {$IF DEFINED(BSD)} + {$IF DEFINED(DARWIN)} + {$DEFINE NUMCPULIB_APPLE} + {$IF DEFINED(NUMCPULIB_ARM) OR DEFINED(NUMCPULIB_AARCH64)} + {$DEFINE NUMCPULIB_IOS} + {$ELSE} + {$DEFINE NUMCPULIB_MACOS} + {$IFEND} + {$ELSEIF DEFINED(FREEBSD) OR DEFINED(NETBSD) OR DEFINED(OPENBSD) OR DEFINED(DRAGONFLY)} + {$DEFINE NUMCPULIB_GENERIC_BSD} + {$IFEND} + {$ELSEIF DEFINED(ANDROID)} + {$DEFINE NUMCPULIB_ANDROID} + {$ELSEIF DEFINED(LINUX)} + {$DEFINE NUMCPULIB_LINUX} + {$ELSEIF DEFINED(SOLARIS)} + {$DEFINE NUMCPULIB_SOLARIS} + {$ELSE} + {$DEFINE NUMCPULIB_UNDEFINED_UNIX_VARIANTS} + {$IFEND} +{$ELSE} + //{$MESSAGE ERROR 'UNSUPPORTED TARGET.'} +{$IFEND} + +{$IFDEF NUMCPULIB_ANDROID} + {$DEFINE NUMCPULIB_LINUX} +{$ENDIF} + +{$IF DEFINED(NUMCPULIB_GENERIC_BSD) OR DEFINED(NUMCPULIB_APPLE)} + {$DEFINE NUMCPULIB_HAS_SYSCTL} +{$IFEND} + +{$IF DEFINED(NUMCPULIB_LINUX) OR DEFINED(NUMCPULIB_GENERIC_BSD) OR DEFINED(NUMCPULIB_SOLARIS) OR DEFINED(NUMCPULIB_APPLE)} + {$DEFINE NUMCPULIB_HAS_SYSCONF} +{$IFEND} + +{$IF DEFINED(NUMCPULIB_LINUX) OR DEFINED(NUMCPULIB_SOLARIS)} + {$DEFINE NUMCPULIB_WILL_PARSE_DATA} +{$IFEND} + +{$ENDIF FPC} + +(* &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& *) + +{$IFDEF DELPHI} + + // XE3 and Above +{$IF CompilerVersion >= 24.0} + {$DEFINE DELPHIXE3_UP} + {$LEGACYIFEND ON} + {$ZEROBASEDSTRINGS OFF} +{$IFEND} + +{$IFDEF CPU386} + {$DEFINE NUMCPULIB_X86} +{$ENDIF} + +{$IFDEF CPUX64} + {$DEFINE NUMCPULIB_X86_64} +{$ENDIF} + +{$IFDEF CPUARM32} + {$DEFINE NUMCPULIB_ARM} +{$ENDIF} + +{$IFDEF CPUARM64} + {$DEFINE NUMCPULIB_AARCH64} +{$ENDIF} + +{$IF DEFINED(NUMCPULIB_ARM) OR DEFINED(NUMCPULIB_AARCH64)} + {$DEFINE NUMCPULIB_ARMCPU} +{$IFEND} + +{$IFDEF IOS} + {$IFNDEF CPUARM} + {$DEFINE NUMCPULIB_IOSSIM} + {$ENDIF} +{$ENDIF} + +{$IFDEF IOS} + {$DEFINE NUMCPULIB_IOS} +{$ENDIF} + +{$IFDEF MSWINDOWS} + {$DEFINE NUMCPULIB_MSWINDOWS} +{$ENDIF} + +{$IFDEF MACOS} + {$IFNDEF IOS} + {$DEFINE NUMCPULIB_MACOS} + {$ENDIF} +{$ENDIF} + +{$IFDEF ANDROID} + {$DEFINE NUMCPULIB_ANDROID} +{$ENDIF} + +{$IF DEFINED(NUMCPULIB_IOS) OR DEFINED(NUMCPULIB_MACOS)} + {$DEFINE NUMCPULIB_APPLE} +{$IFEND} + +{$IF DEFINED(LINUX) OR DEFINED(NUMCPULIB_ANDROID)} + {$DEFINE NUMCPULIB_LINUX} +{$IFEND} + +{$IF DEFINED(NUMCPULIB_APPLE)} + {$DEFINE NUMCPULIB_HAS_SYSCTL} +{$IFEND} + +{$IF DEFINED(NUMCPULIB_LINUX) OR DEFINED(NUMCPULIB_APPLE)} + {$DEFINE NUMCPULIB_HAS_SYSCONF} +{$IFEND} + +{$IF DEFINED(NUMCPULIB_MSWINDOWS)} +// XE2 and Above + {$IF CompilerVersion >= 23.0} + {$DEFINE DELPHIXE2_UP} + {$DEFINE HAS_GET_LOGICAL_PROCESSOR_INFORMATION_INBUILT} + {$IFEND} +{$IFEND} + +{$IFDEF NUMCPULIB_LINUX} + {$DEFINE NUMCPULIB_WILL_PARSE_DATA} +{$ENDIF} + +{$ENDIF DELPHI} + +interface + +uses +{$IFDEF NUMCPULIB_MSWINDOWS} + Windows, +{$ENDIF} // ENDIF NUMCPULIB_MSWINDOWS + // ================================================================// +{$IFDEF NUMCPULIB_HAS_SYSCONF} +{$IFDEF FPC} + unixtype, +{$IFDEF LINUX} + Linux, +{$ENDIF} // ENDIF LINUX +{$ELSE} + Posix.Unistd, +{$ENDIF} // ENDIF FPC +{$ENDIF} // ENDIF NUMCPULIB_HAS_SYSCONF + // ================================================================// +{$IFDEF NUMCPULIB_HAS_SYSCTL} +{$IFDEF FPC} + sysctl, +{$ELSE} + Posix.SysTypes, + Posix.SysSysctl, +{$ENDIF} // ENDIF FPC +{$ENDIF} // ENDIF NUMCPULIB_HAS_SYSCTL + // ================================================================// +{$IFDEF NUMCPULIB_APPLE} +{$IFDEF NUMCPULIB_MACOS} +{$IFDEF FPC} + CocoaAll, +{$ELSE} + Macapi.AppKit, +{$ENDIF} // ENDIF FPC +{$ENDIF} // ENDIF NUMCPULIB_MACOS +{$ENDIF} // ENDIF NUMCPULIB_APPLE + // ================================================================// +{$IFDEF NUMCPULIB_WILL_PARSE_DATA} +{$IFDEF NUMCPULIB_SOLARIS} + Process, +{$ENDIF} // ENDIF NUMCPULIB_SOLARIS + Classes, + StrUtils, +{$ENDIF} // ENDIF NUMCPULIB_WILL_PARSE_DATA + + // ================================================================// + SysUtils; + +type + /// + /// + /// A class with utilities to determine the number of CPUs available on + /// the current system. + /// + /// + /// This information can be used as a guide to how many tasks can be + /// run in parallel. + /// + /// + /// There are many properties of the system architecture that will + /// affect parallelism, for example memory access speeds (for all the + /// caches and RAM) and the physical architecture of the processor, so + /// the number of CPUs should be used as a rough guide only. + /// + /// + TNumCPULib = class sealed(TObject) + + strict private + + // ================================================================// +{$IFDEF NUMCPULIB_HAS_SYSCONF} + class function GetAppropriateSysConfNumber(): Int32; static; +{$ENDIF} + // ================================================================// +{$IFDEF NUMCPULIB_HAS_SYSCTL} +{$IFDEF NUMCPULIB_APPLE} + class function GetValueUsingSysCtlByName(const AName: String) + : UInt64; static; +{$ENDIF} + class function GetLogicalCPUCountUsingSysCtl(): UInt32; static; +{$ENDIF} + // ================================================================// +{$IFDEF NUMCPULIB_MSWINDOWS} + + const + KERNEL32 = 'kernel32.dll'; + +{$IFNDEF HAS_GET_LOGICAL_PROCESSOR_INFORMATION_INBUILT} + + type + + TLogicalProcessorRelationship = (RelationProcessorCore = 0, + RelationNumaNode = 1, RelationCache = 2, RelationProcessorPackage = 3, + RelationGroup = 4, RelationAll = $FFFF); + TProcessorCacheType = (CacheUnified, CacheInstruction, CacheData, + CacheTrace); + + TCacheDescriptor = record + Level: Byte; + Associativity: Byte; + LineSize: Word; + Size: DWORD; + pcType: TProcessorCacheType; + end; + + PSystemLogicalProcessorInformation = ^TSystemLogicalProcessorInformation; + + TSystemLogicalProcessorInformation = record + ProcessorMask: ULONG_PTR; + Relationship: TLogicalProcessorRelationship; + case Int32 of + 0: + (Flags: Byte); + 1: + (NodeNumber: DWORD); + 2: + (Cache: TCacheDescriptor); + 3: + (Reserved: array [0 .. 1] of ULONGLONG); + end; + + KAffinity = NativeUInt; + + TGroupAffinity = record + Mask: KAffinity; + Group: Word; + Reserved: array [0 .. 2] of Word; + end; + + TProcessorRelationship = record + Flags: Byte; + Reserved: array [0 .. 20] of Byte; + GroupCount: Word; + GroupMask: array [0 .. 0] of TGroupAffinity; + end; + + TNumaNodeRelationship = record + NodeNumber: DWORD; + Reserved: array [0 .. 19] of Byte; + GroupMask: TGroupAffinity; + end; + + TCacheRelationship = record + Level: Byte; + Associativity: Byte; + LineSize: Word; + CacheSize: DWORD; + _Type: TProcessorCacheType; + Reserved: array [0 .. 19] of Byte; + GroupMask: TGroupAffinity; + end; + + TProcessorGroupInfo = record + MaximumProcessorCount: Byte; + ActiveProcessorCount: Byte; + Reserved: array [0 .. 37] of Byte; + ActiveProcessorMask: KAffinity; + end; + + TGroupRelationship = record + MaximumGroupCount: Word; + ActiveGroupCount: Word; + Reserved: array [0 .. 19] of Byte; + GroupInfo: array [0 .. 0] of TProcessorGroupInfo; + end; + + PSystemLogicalProcessorInformationEx = ^ + TSystemLogicalProcessorInformationEx; + + TSystemLogicalProcessorInformationEx = record + Relationship: TLogicalProcessorRelationship; + Size: DWORD; + case Int32 of + 0: + (Processor: TProcessorRelationship); + 1: + (NumaNode: TNumaNodeRelationship); + 2: + (Cache: TCacheRelationship); + 3: + (Group: TGroupRelationship); + end; + + MEMORYSTATUSEX = record + dwLength : DWORD; + dwMemoryLoad : DWORD; + ullTotalPhys : uint64; + ullAvailPhys : uint64; + ullTotalPageFile : uint64; + ullAvailPageFile : uint64; + ullTotalVirtual : uint64; + ullAvailVirtual : uint64; + ullAvailExtendedVirtual : uint64; + end; + TMemoryStatusEx = MEMORYSTATUSEX; + +{$ENDIF} + + // ================================================================// + + type + TGetLogicalProcessorInformation = function(Buffer: +{$IFNDEF HAS_GET_LOGICAL_PROCESSOR_INFORMATION_INBUILT}TNumCPULib.{$ENDIF}PSystemLogicalProcessorInformation; var ReturnLength: DWORD): BOOL; stdcall; + + TGetLogicalProcessorInformationEx = function(RelationshipType + : TLogicalProcessorRelationship; Buffer: +{$IFNDEF HAS_GET_LOGICAL_PROCESSOR_INFORMATION_INBUILT}TNumCPULib.{$ENDIF}PSystemLogicalProcessorInformationEx; var ReturnLength: DWORD): BOOL; stdcall; + + TGetGlobalMemoryStatus = procedure(var Buffer:MemoryStatus); stdcall; + TGetGlobalMemoryStatusEx = function(var Buffer:TMemoryStatusEx): BOOL; stdcall; + + class var + + FIsGetLogicalProcessorInformationAvailable, + FIsGetLogicalProcessorInformationAvailableEx: Boolean; + FGetLogicalProcessorInformation: TGetLogicalProcessorInformation; + FGetLogicalProcessorInformationEx: TGetLogicalProcessorInformationEx; + + FIsGetGlobalMemoryStatusAvailable, + FIsGetGlobalMemoryStatusAvailableEx: Boolean; + FGetGlobalMemoryStatus: TGetGlobalMemoryStatus; + FGetGlobalMemoryStatusEx: TGetGlobalMemoryStatusEx; + + // ================================================================// + + type + TProcessorInformation = record + LogicalProcessorCount: UInt32; + ProcessorCoreCount: UInt32; + end; + + type + TProcessorInformationEx = record + LogicalProcessorCount: UInt32; + ProcessorCoreCount: UInt32; + end; + + // ================================================================// + class function GetProcedureAddress(ModuleHandle: THandle; + const AProcedureName: String; var AFunctionFound: Boolean): Pointer; static; + class function IsGetLogicalProcessorInformationAvailable(): Boolean; static; + class function IsGetLogicalProcessorInformationExAvailable(): Boolean; static; + class function CountSetBits(ABitMask: NativeUInt): UInt32; static; + class function GetProcessorInfo(): TProcessorInformation; static; + class function GetProcessorInfoEx(): TProcessorInformationEx; static; + + class function IsGetGlobalMemoryStatusAvailable(): Boolean; static; + class function IsGetGlobalMemoryStatusAvailableEx(): Boolean; static; + class function GetPhysicalMemoryEx(): UInt32; + class function GetPhysicalMemory(): UInt32; + + class function GetLogicalCPUCountWindows(): UInt32; static; + class function GetPhysicalCPUCountWindows(): UInt32; static; + class function GetTotalPhysicalMemoryWindows(): UInt32; static; +{$ENDIF} + // ================================================================// +{$IFDEF NUMCPULIB_APPLE} + class function GetLogicalCPUCountApple(): UInt32; static; + class function GetPhysicalCPUCountApple(): UInt32; static; + class function GetTotalPhysicalMemoryApple(): UInt32; static; +{$ENDIF} + // ================================================================// +{$IFDEF NUMCPULIB_WILL_PARSE_DATA} + + type + TNumCPULibStringArray = array of String; + + class function SplitString(const AInputString: String; ADelimiter: Char) + : TNumCPULibStringArray; static; + + class function ParseLastString(const AInputString: String): String; static; + class function ParseInt32(const AInputString: String; + ADefault: Int32): Int32; + class function ParseLastInt32(const AInputString: String; ADefault: Int32) + : Int32; static; + + class function BeginsWith(const AInputString, ASubString: string; + AIgnoreCase: Boolean; AOffset: Int32 = 1): Boolean; static; +{$ENDIF} + // ================================================================// +{$IFDEF NUMCPULIB_LINUX} + + type + TLogicalProcessor = record + private + var + ProcessorNumber, PhysicalProcessorNumber, PhysicalPackageNumber: UInt32; + public + class function Create(AProcessorNumber, APhysicalProcessorNumber, + APhysicalPackageNumber: UInt32): TLogicalProcessor; static; + end; + + class procedure ReadFileContents(const AFilePath: String; + var AOutputParameters: TStringList); static; + class function GetLogicalCPUCountLinux(): UInt32; static; + class function GetPhysicalCPUCountLinux(): UInt32; static; + class function GetTotalPhysicalMemoryLinux(): UInt32; static; + class function GetTotalSwapMemoryLinux(): UInt32; static; +{$ENDIF} + // ================================================================// +{$IFDEF NUMCPULIB_SOLARIS} + class procedure ExecuteAndParseProcessOutput(const ACallingProcess: String; + AInputParameters: TStringList; var AOutputParameters: TStringList); + class function GetLogicalCPUCountSolaris(): UInt32; static; + class function GetPhysicalCPUCountSolaris(): UInt32; static; + class function GetTotalPhysicalMemorySolaris(): UInt32; static; +{$ENDIF} + // ================================================================// +{$IFDEF NUMCPULIB_GENERIC_BSD} + class function GetLogicalCPUCountGenericBSD(): UInt32; static; +{$ENDIF} + // ================================================================// + + class procedure Boot(); static; + class constructor NumCPULib(); + + public + + /// + /// This function will get the number of logical cores. Sometimes this is + /// different from the number of physical cores. + /// + class function GetLogicalCPUCount(): UInt32; static; + + /// + /// This function will get the number of physical cores. + /// + class function GetPhysicalCPUCount(): UInt32; static; + + class function GetTotalPhysicalMemory(): UInt32; static; + class function GetTotalSwapMemory(): UInt32; static; + end; + +{$IFDEF NUMCPULIB_HAS_SYSCONF} +{$IFDEF FPC} + +function sysconf(i: cint): clong; cdecl; external 'c' name 'sysconf'; +{$ENDIF} +{$ENDIF} + +implementation + +{ TNumCPULib } + +class procedure TNumCPULib.Boot(); +begin +{$IFDEF NUMCPULIB_MSWINDOWS} + FIsGetLogicalProcessorInformationAvailable := + IsGetLogicalProcessorInformationAvailable(); + FIsGetLogicalProcessorInformationAvailableEx := + IsGetLogicalProcessorInformationExAvailable(); + + FIsGetGlobalMemoryStatusAvailable := + IsGetGlobalMemoryStatusAvailable(); + FIsGetGlobalMemoryStatusAvailableEx := + IsGetGlobalMemoryStatusAvailableEx(); +{$ENDIF} +end; + +class constructor TNumCPULib.NumCPULib; +begin + TNumCPULib.Boot(); +end; + +// ================================================================// +{$IFDEF NUMCPULIB_HAS_SYSCONF} + +class function TNumCPULib.GetAppropriateSysConfNumber(): Int32; +begin + // On ARM targets, processors could be turned off to save power So we + // use `_SC_NPROCESSORS_CONF` to get the real number. + // ****************************************************************// + // NUMCPULIB_LINUX +{$IFDEF NUMCPULIB_LINUX} +{$IFDEF NUMCPULIB_ARMCPU} +{$IFDEF NUMCPULIB_ANDROID} + Result := 96; // _SC_NPROCESSORS_CONF +{$ELSE} + // Devices like RPI + Result := 83; // _SC_NPROCESSORS_CONF +{$ENDIF} +{$ELSE} + // for non ARM Linux like CPU's +{$IFDEF NUMCPULIB_ANDROID} + Result := 97; // _SC_NPROCESSORS_ONLN +{$ELSE} + Result := 84; // _SC_NPROCESSORS_ONLN +{$ENDIF} // ENDIF NUMCPULIB_ANDROID + +{$ENDIF} // ENDIF NUMCPULIB_ARMCPU +{$ENDIF} // ENDIF NUMCPULIB_LINUX + // ****************************************************************// + // NUMCPULIB_GENERIC_BSD +{$IFDEF NUMCPULIB_GENERIC_BSD} +{$IF DEFINED(FREEBSD) OR DEFINED(DRAGONFLY)} + Result := 58; // _SC_NPROCESSORS_ONLN +{$IFEND} +{$IFDEF OPENBSD} + Result := 503; // _SC_NPROCESSORS_ONLN +{$ENDIF} +{$IFDEF NETBSD} + Result := 1002; // _SC_NPROCESSORS_ONLN +{$ENDIF} +{$ENDIF} // ENDIF NUMCPULIB_GENERIC_BSD + // ****************************************************************// + // NUMCPULIB_SOLARIS +{$IFDEF NUMCPULIB_SOLARIS} +{$IFDEF NUMCPULIB_ARMCPU} + Result := 14; // _SC_NPROCESSORS_CONF +{$ELSE} + Result := 15; // _SC_NPROCESSORS_ONLN +{$ENDIF} +{$ENDIF} // ENDIF NUMCPULIB_SOLARIS + // ****************************************************************// + // NUMCPULIB_APPLE +{$IFDEF NUMCPULIB_APPLE} +{$IFDEF NUMCPULIB_ARMCPU} + Result := 57; // _SC_NPROCESSORS_CONF +{$ELSE} + Result := 58; // _SC_NPROCESSORS_ONLN +{$ENDIF} +{$ENDIF} // ENDIF NUMCPULIB_APPLE +end; +{$ENDIF} +// ================================================================// +{$IFDEF NUMCPULIB_HAS_SYSCTL} +{$IFDEF NUMCPULIB_APPLE} + +class function TNumCPULib.GetValueUsingSysCtlByName + (const AName: String): UInt64; +var + LLen: size_t; +begin + LLen := System.SizeOf(Result); +{$IFDEF FPC} + fpsysctlbyname(PChar(AName), @Result, @LLen, nil, 0); +{$ELSE} + SysCtlByName(PAnsiChar(AName), @Result, @LLen, nil, 0); +{$ENDIF} +end; +{$ENDIF} + +class function TNumCPULib.GetLogicalCPUCountUsingSysCtl(): UInt32; +var + LMib: array [0 .. 1] of Int32; + LLen: size_t; +begin + LMib[0] := CTL_HW; + LMib[1] := HW_NCPU; + LLen := System.SizeOf(Result); +{$IFDEF FPC} +{$IF DEFINED(VER3_0_0) OR DEFINED(VER3_0_2)} + fpsysctl(PChar(@LMib), 2, @Result, @LLen, nil, 0); +{$ELSE} + fpsysctl(@LMib, 2, @Result, @LLen, nil, 0); +{$IFEND} +{$ELSE} + sysctl(@LMib, 2, @Result, @LLen, nil, 0); +{$ENDIF} +end; +{$ENDIF} +// ================================================================// +{$IFDEF NUMCPULIB_MSWINDOWS} + +class function TNumCPULib.CountSetBits(ABitMask: NativeUInt): UInt32; +var + LShift, LIdx: UInt32; + LBitTest: NativeUInt; +begin + LShift := (System.SizeOf(NativeUInt) * 8) - 1; + Result := 0; + LBitTest := NativeUInt(1) shl LShift; + LIdx := 0; + while LIdx <= LShift do + begin + if (ABitMask and LBitTest) <> 0 then + begin + System.Inc(Result); + end; + LBitTest := LBitTest shr 1; + System.Inc(LIdx); + end; +end; + +class function TNumCPULib.GetProcessorInfo(): TProcessorInformation; +var + LReturnLength: DWORD; + LProcInfo, LCurrentInfo: PSystemLogicalProcessorInformation; +begin + LReturnLength := 0; + Result := Default (TProcessorInformation); + + FGetLogicalProcessorInformation(nil, LReturnLength); + if GetLastError <> ERROR_INSUFFICIENT_BUFFER then + begin + RaiseLastOSError; + end + else + begin + System.GetMem(LProcInfo, LReturnLength); + try + if not FGetLogicalProcessorInformation(LProcInfo, LReturnLength) then + begin + RaiseLastOSError; + end + else + begin + LCurrentInfo := LProcInfo; + while (NativeUInt(LCurrentInfo) - NativeUInt(LProcInfo)) < + LReturnLength do + begin + case LCurrentInfo.Relationship of + RelationProcessorCore: + begin + System.Inc(Result.ProcessorCoreCount); + Result.LogicalProcessorCount := Result.LogicalProcessorCount + + CountSetBits(LCurrentInfo.ProcessorMask); + end; + end; + LCurrentInfo := PSystemLogicalProcessorInformation + (NativeUInt(LCurrentInfo) + + System.SizeOf(TSystemLogicalProcessorInformation)); + end; + end; + finally + System.FreeMem(LProcInfo); + end; + end; +end; + +class function TNumCPULib.GetProcessorInfoEx: TProcessorInformationEx; +var + LReturnLength: DWORD; + LProcInfo, LCurrentInfo: PSystemLogicalProcessorInformationEx; + LIdx: Int32; +begin + LReturnLength := 0; + Result := Default (TProcessorInformationEx); + + FGetLogicalProcessorInformationEx(RelationAll, nil, LReturnLength); + if GetLastError <> ERROR_INSUFFICIENT_BUFFER then + begin + RaiseLastOSError; + end + else + begin + System.GetMem(LProcInfo, LReturnLength); + try + if not FGetLogicalProcessorInformationEx(RelationAll, LProcInfo, + LReturnLength) then + begin + RaiseLastOSError; + end + else + begin + LCurrentInfo := LProcInfo; + while (NativeUInt(LCurrentInfo) - NativeUInt(LProcInfo)) < + LReturnLength do + begin + case LCurrentInfo.Relationship of + RelationProcessorCore: + begin + System.Inc(Result.ProcessorCoreCount); + for LIdx := 0 to System.Pred + (LCurrentInfo.Processor.GroupCount) do + begin + Result.LogicalProcessorCount := Result.LogicalProcessorCount + + CountSetBits(LCurrentInfo.Processor.GroupMask[LIdx].Mask); + end; + end; + end; + LCurrentInfo := PSystemLogicalProcessorInformationEx + (NativeUInt(LCurrentInfo) + LCurrentInfo.Size); + end; + end; + finally + System.FreeMem(LProcInfo); + end; + end; +end; + +class function TNumCPULib.GetLogicalCPUCountWindows(): UInt32; +var + LIdx: Int32; + LProcessAffinityMask, LSystemAffinityMask: DWORD_PTR; + LMask: DWORD; + LSystemInfo: SYSTEM_INFO; + LProcInfo: TProcessorInformation; + LProcInfoEx: TProcessorInformationEx; +begin + if IsGetLogicalProcessorInformationExAvailable then + begin + LProcInfoEx := GetProcessorInfoEx; + Result := LProcInfoEx.LogicalProcessorCount; + Exit; + end; + if IsGetLogicalProcessorInformationAvailable then + begin + LProcInfo := GetProcessorInfo; + Result := LProcInfo.LogicalProcessorCount; + Exit; + end; + // fallback if non of the above are available + // returns total number of processors available to system including logical hyperthreaded processors + LProcessAffinityMask := 0; + LSystemAffinityMask := 0; + if GetProcessAffinityMask(GetCurrentProcess, LProcessAffinityMask, + LSystemAffinityMask) then + begin + Result := 0; + for LIdx := 0 to 31 do + begin + LMask := DWORD(1) shl LIdx; + if (LProcessAffinityMask and LMask) <> 0 then + begin + System.Inc(Result); + end; + end; + end + else + begin + // can't get the affinity mask so we just report the total number of processors + LSystemInfo := Default (SYSTEM_INFO); + GetSystemInfo(LSystemInfo); + Result := LSystemInfo.dwNumberOfProcessors; + end; +end; + +class function TNumCPULib.GetPhysicalCPUCountWindows(): UInt32; +var + LProcInfo: TProcessorInformation; + LProcInfoEx: TProcessorInformationEx; +begin + Result := 0; + if IsGetLogicalProcessorInformationExAvailable then + begin + LProcInfoEx := GetProcessorInfoEx; + Result := LProcInfoEx.ProcessorCoreCount; + Exit; + end; + if IsGetLogicalProcessorInformationAvailable then + begin + LProcInfo := GetProcessorInfo; + Result := LProcInfo.ProcessorCoreCount; + Exit; + end; +end; + +class function TNumCPULib.GetPhysicalMemoryEx(): UInt32; +var + M: TMemoryStatusEx; +begin + Result := 0; + FillChar(M, SizeOf(TMemoryStatusEx), 0); + M.dwLength := SizeOf(TMemoryStatusEx); + if FGetGlobalMemoryStatusEx(M) then + Result := (M.ullTotalPhys shr 20); +end; + +class function TNumCPULib.GetPhysicalMemory(): UInt32; +var + M: TMemoryStatus; +begin + FillChar(M, SizeOf(TMemoryStatus), 0); + M.dwLength := SizeOf(TMemoryStatus); + FGetGlobalMemoryStatus(M); + Result := (M.dwTotalPhys shr 20); +end; + +class function TNumCPULib.GetTotalPhysicalMemoryWindows(): UInt32; +begin + Result := 0; + if IsGetGlobalMemoryStatusAvailableEx then + begin + Result := GetPhysicalMemoryEx(); + Exit; + end; + if IsGetGlobalMemoryStatusAvailable then + begin + Result := GetPhysicalMemory(); + Exit; + end; +end; + +class function TNumCPULib.GetProcedureAddress(ModuleHandle: THandle; + const AProcedureName: String; var AFunctionFound: Boolean): Pointer; +begin + Result := GetProcAddress(ModuleHandle, PChar(AProcedureName)); + if Result = Nil then + begin + AFunctionFound := False; + end; +end; + +class function TNumCPULib.IsGetLogicalProcessorInformationAvailable(): Boolean; +var + ModuleHandle: THandle; +begin + Result := False; + ModuleHandle := SafeLoadLibrary(KERNEL32, SEM_FAILCRITICALERRORS); + if ModuleHandle <> 0 then + begin + Result := True; + FGetLogicalProcessorInformation := GetProcedureAddress(ModuleHandle, + 'GetLogicalProcessorInformation', Result); + end; +end; + +class function TNumCPULib.IsGetLogicalProcessorInformationExAvailable: Boolean; +var + ModuleHandle: THandle; +begin + Result := False; + ModuleHandle := SafeLoadLibrary(KERNEL32, SEM_FAILCRITICALERRORS); + if ModuleHandle <> 0 then + begin + Result := True; + FGetLogicalProcessorInformationEx := GetProcedureAddress(ModuleHandle, + 'GetLogicalProcessorInformationEx', Result); + end; +end; + +class function TNumCPULib.IsGetGlobalMemoryStatusAvailable(): Boolean; +var + ModuleHandle: THandle; +begin + Result := False; + ModuleHandle := SafeLoadLibrary(KERNEL32, SEM_FAILCRITICALERRORS); + if ModuleHandle <> 0 then + begin + Result := True; + FGetGlobalMemoryStatus := GetProcedureAddress(ModuleHandle, + 'GlobalMemoryStatus', Result); + end; +end; + +class function TNumCPULib.IsGetGlobalMemoryStatusAvailableEx: Boolean; +var + ModuleHandle: THandle; +begin + Result := False; + ModuleHandle := SafeLoadLibrary(KERNEL32, SEM_FAILCRITICALERRORS); + if ModuleHandle <> 0 then + begin + Result := True; + FGetGlobalMemoryStatusEx := GetProcedureAddress(ModuleHandle, + 'GlobalMemoryStatusEx', Result); + end; +end; + + +{$ENDIF} +// ================================================================// +{$IFDEF NUMCPULIB_APPLE} + +class function TNumCPULib.GetLogicalCPUCountApple(): UInt32; +//var +// LTempRes: Int32; +begin + Result := UInt32(GetValueUsingSysCtlByName('hw.logicalcpu')); + (* + +{$IF DEFINED(NUMCPULIB_MACOS)} + // >= (Mac OS X 10.4+) + if NSAppKitVersionNumber >= 824 then // NSAppKitVersionNumber10_4 + begin + LTempRes := sysconf(GetAppropriateSysConfNumber()); + end + else + begin + // fallback for when sysconf API is not available + LTempRes := Int32(GetLogicalCPUCountUsingSysCtl()); + end; +{$ELSE} + LTempRes := sysconf(GetAppropriateSysConfNumber()); +{$IFEND} + // final fallback if all above fails + if LTempRes < 1 then + begin + Result := UInt32(GetValueUsingSysCtlByName('hw.logicalcpu')); + end + else + begin + Result := UInt32(LTempRes); + end; + *) +end; + +class function TNumCPULib.GetPhysicalCPUCountApple(): UInt32; +begin + Result := UInt32(GetValueUsingSysCtlByName('hw.physicalcpu')); +end; + +class function TNumCPULib.GetTotalPhysicalMemoryApple(): UInt32; +begin + Result := (GetValueUsingSysCtlByName('hw.memsize') shr 20); +end; +{$ENDIF} +// ================================================================// + +{$IFDEF NUMCPULIB_WILL_PARSE_DATA} + +class function TNumCPULib.SplitString(const AInputString: String; + ADelimiter: Char): TNumCPULibStringArray; +var + LPosStart, LPosDel, LSplitPoints, LIdx, LLowIndex, LHighIndex, LLength: Int32; +begin + Result := Nil; + if AInputString <> '' then + begin + { Determine the length of the resulting array } + LLowIndex := 1; + LHighIndex := System.Length(AInputString); + LSplitPoints := 0; + for LIdx := LLowIndex to LHighIndex do + begin + if (ADelimiter = AInputString[LIdx]) then + begin + System.Inc(LSplitPoints); + end; + end; + + System.SetLength(Result, LSplitPoints + 1); + + { Split the string and fill the resulting array } + + LIdx := 0; + LLength := System.Length(ADelimiter); + LPosStart := 1; + LPosDel := System.Pos(ADelimiter, AInputString); + while LPosDel > 0 do + begin + Result[LIdx] := System.Copy(AInputString, LPosStart, LPosDel - LPosStart); + LPosStart := LPosDel + LLength; + LPosDel := PosEx(ADelimiter, AInputString, LPosStart); + System.Inc(LIdx); + end; + Result[LIdx] := System.Copy(AInputString, LPosStart, + System.Length(AInputString)); + end; +end; + +class function TNumCPULib.ParseLastString(const AInputString: String): String; +var + LSplitResult: TNumCPULibStringArray; +begin + LSplitResult := SplitString(AInputString, ' '); + if (System.Length(LSplitResult) < 1) then + begin + Result := Trim(AInputString); + end + else + begin + Result := Trim(LSplitResult[System.Length(LSplitResult) - 1]); + end; +end; + +class function TNumCPULib.ParseInt32(const AInputString: String; + ADefault: Int32): Int32; +var + LLocalString: String; +begin + LLocalString := AInputString; + if BeginsWith(LowerCase(LLocalString), '0x', False) then + begin + Result := StrToIntDef(StringReplace(LLocalString, '0x', '$', + [rfReplaceAll, rfIgnoreCase]), ADefault); + end + else + begin + Result := StrToIntDef(LLocalString, ADefault); + end; +end; + + +class function TNumCPULib.ParseLastInt32(const AInputString: String; + ADefault: Int32): Int32; +var + LLocalString: String; +begin + LLocalString := ParseLastString(AInputString); + result:=ParseInt32(LLocalString,ADefault); +end; + +class function TNumCPULib.BeginsWith(const AInputString, ASubString: String; + AIgnoreCase: Boolean; AOffset: Int32): Boolean; +var + LIdx: Int32; + LPtrInputString, LPtrSubString: PChar; +begin + LIdx := System.Length(ASubString); + Result := LIdx > 0; + LPtrInputString := PChar(AInputString); + System.Inc(LPtrInputString, AOffset - 1); + LPtrSubString := PChar(ASubString); + if Result then + begin + if AIgnoreCase then + begin + Result := StrLiComp(LPtrSubString, LPtrInputString, LIdx) = 0 + end + else + begin + Result := StrLComp(LPtrSubString, LPtrInputString, LIdx) = 0 + end; + end; +end; +{$ENDIF} +// ================================================================// + +{$IFDEF NUMCPULIB_LINUX} + +class function TNumCPULib.TLogicalProcessor.Create(AProcessorNumber, + APhysicalProcessorNumber, APhysicalPackageNumber: UInt32): TLogicalProcessor; +begin + Result := Default (TLogicalProcessor); + Result.ProcessorNumber := AProcessorNumber; + Result.PhysicalProcessorNumber := APhysicalProcessorNumber; + Result.PhysicalPackageNumber := APhysicalPackageNumber; +end; + +class procedure TNumCPULib.ReadFileContents(const AFilePath: String; + var AOutputParameters: TStringList); +const + BUF_SIZE = 2048; // Buffer size for reading the output in chunks +var + LOutputStream: TStream; + LFileStream: TFileStream; + LBytesRead: LongInt; + LBuffer: array [0 .. BUF_SIZE - 1] of Byte; +begin + if SysUtils.FileExists(AFilePath) then + begin + LFileStream := TFileStream.Create(AFilePath, fmOpenRead); + try + LOutputStream := TMemoryStream.Create; + try + // All data from file is read in a loop until no more data is available + repeat + // Get the new data from the file to a maximum of the LBuffer size that was allocated. + // Note that all read(...) calls will block except for the last one, which returns 0 (zero). + LBytesRead := LFileStream.Read(LBuffer, BUF_SIZE); + + // Add the bytes that were read to the stream for later usage + LOutputStream.Write(LBuffer, LBytesRead) + + until LBytesRead = 0; // Stop if no more data is available + + // Required to make sure all data is copied from the start + LOutputStream.Position := 0; + AOutputParameters.LoadFromStream(LOutputStream); + finally + LOutputStream.Free; + end; + finally + LFileStream.Free; + end; + end; +end; + +class function TNumCPULib.GetLogicalCPUCountLinux(): UInt32; +begin + Result := UInt32(sysconf(GetAppropriateSysConfNumber())); +end; + +class function TNumCPULib.GetPhysicalCPUCountLinux(): UInt32; +var + LProcCpuInfos, LPhysicalProcessorsDetails: TStringList; + LIdx, LJIdx, LLogicalProcessorsIdx: Int32; + LCurrentProcessor, LCurrentCore, LCurrentPackage: UInt32; + LFirst: Boolean; + LLogicalProcessors: array of TLogicalProcessor; + LogicalProcessor: TLogicalProcessor; + LLineProcCpuInfo: String; +begin + LProcCpuInfos := TStringList.Create(); + LCurrentProcessor := 0; + LCurrentCore := 0; + LCurrentPackage := 0; + LFirst := True; + try + ReadFileContents('/proc/cpuinfo', LProcCpuInfos); + System.SetLength(LLogicalProcessors, LProcCpuInfos.Count); + // allocate enough space + LLogicalProcessorsIdx := 0; + for LIdx := 0 to System.Pred(LProcCpuInfos.Count) do + begin + // Count logical processors + LLineProcCpuInfo := LProcCpuInfos[LIdx]; + if (BeginsWith(LLineProcCpuInfo, 'processor', False)) then + begin + if (not LFirst) then + begin + LLogicalProcessors[LLogicalProcessorsIdx] := + TLogicalProcessor.Create(LCurrentProcessor, LCurrentCore, + LCurrentPackage); + System.Inc(LLogicalProcessorsIdx); + end + else + begin + LFirst := False; + end; + LCurrentProcessor := UInt32(ParseLastInt32(LLineProcCpuInfo, 0)); + end + else if (BeginsWith(LLineProcCpuInfo, 'core id', False) or + BeginsWith(LLineProcCpuInfo, 'cpu number', False)) then + begin + // Count unique combinations of core id and physical id. + LCurrentCore := UInt32(ParseLastInt32(LLineProcCpuInfo, 0)); + end + else if (BeginsWith(LLineProcCpuInfo, 'physical id', False)) then + begin + LCurrentPackage := UInt32(ParseLastInt32(LLineProcCpuInfo, 0)); + end; + end; + + LLogicalProcessors[LLogicalProcessorsIdx] := + TLogicalProcessor.Create(LCurrentProcessor, LCurrentCore, + LCurrentPackage); + System.Inc(LLogicalProcessorsIdx); + // reduce to used size + System.SetLength(LLogicalProcessors, LLogicalProcessorsIdx); + LPhysicalProcessorsDetails := TStringList.Create(); + LPhysicalProcessorsDetails.Sorted := True; + LPhysicalProcessorsDetails.Duplicates := dupIgnore; + try + for LJIdx := 0 to System.Pred(System.Length(LLogicalProcessors)) do + begin + LogicalProcessor := LLogicalProcessors[LJIdx]; + LPhysicalProcessorsDetails.Add + (Format('%u:%u', [LogicalProcessor.PhysicalProcessorNumber, + LogicalProcessor.PhysicalPackageNumber])); + end; + // LogicalProcessorCount := System.Length(LLogicalProcessors); + Result := UInt32(LPhysicalProcessorsDetails.Count); + finally + LPhysicalProcessorsDetails.Free; + end; + finally + LProcCpuInfos.Free; + end; +end; + +class function TNumCPULib.GetTotalPhysicalMemoryLinux(): UInt32; static; +var + SystemInf: TSysInfo; + mu: cardinal; +begin + result:=0; + try + FillChar({%H-}SystemInf,SizeOf(SystemInf),0); + SysInfo(@SystemInf); + mu := SystemInf.mem_unit; + result := (QWord(SystemInf.totalram*mu) shr 20); + except + end; +end; + +class function TNumCPULib.GetTotalSwapMemoryLinux(): UInt32; static; +var + SystemInf: TSysInfo; + mu: cardinal; +begin + result:=0; + try + FillChar({%H-}SystemInf,SizeOf(SystemInf),0); + SysInfo(@SystemInf); + mu := SystemInf.mem_unit; + result := (QWord(SystemInf.totalswap*mu) shr 20); + except + end; +end; + + +{$ENDIF} +// ================================================================// +{$IFDEF NUMCPULIB_SOLARIS} + +class procedure TNumCPULib.ExecuteAndParseProcessOutput(const ACallingProcess + : String; AInputParameters: TStringList; var AOutputParameters: TStringList); +const + BUF_SIZE = 2048; // Buffer size for reading the output in chunks +var + LProcess: TProcess; + LOutputStream: TStream; + LBytesRead: LongInt; + LBuffer: array [0 .. BUF_SIZE - 1] of Byte; +begin + LProcess := TProcess.Create(nil); + + try + LProcess.Executable := ACallingProcess; + LProcess.Parameters.AddStrings(AInputParameters); + + LProcess.Options := LProcess.Options + [poWaitOnExit, poUsePipes]; + + LProcess.Execute; + + // Create a stream object to store the generated output in. + LOutputStream := TMemoryStream.Create; + + try + // All generated output from LProcess is read in a loop until no more data is available + repeat + // Get the new data from the process to a maximum of the LBuffer size that was allocated. + // Note that all read(...) calls will block except for the last one, which returns 0 (zero). + LBytesRead := LProcess.Output.Read(LBuffer, BUF_SIZE); + + // Add the bytes that were read to the stream for later usage + LOutputStream.Write(LBuffer, LBytesRead) + + until LBytesRead = 0; // Stop if no more data is available + + // Required to make sure all data is copied from the start + LOutputStream.Position := 0; + AOutputParameters.LoadFromStream(LOutputStream); + finally + LOutputStream.Free; + end; + finally + LProcess.Free; + end; +end; + +class function TNumCPULib.GetLogicalCPUCountSolaris(): UInt32; +begin + Result := UInt32(sysconf(GetAppropriateSysConfNumber())); +end; + +class function TNumCPULib.GetPhysicalCPUCountSolaris(): UInt32; +var + LInputParameters, LOuputParameters, LCoreChipIDs: TStringList; + LLineOutputInfo: String; + LIdx: Int32; + LChipId, LCoreId: UInt32; +begin + Result := 0; + + LCoreChipIDs := TStringList.Create(); + LInputParameters := TStringList.Create(); + LOuputParameters := TStringList.Create(); + LCoreChipIDs.Sorted := True; + LCoreChipIDs.Duplicates := dupIgnore; + LOuputParameters.Sorted := True; + LOuputParameters.Duplicates := dupIgnore; + try + LInputParameters.Add('-m'); + LInputParameters.Add('cpu_info'); + + ExecuteAndParseProcessOutput('/usr/bin/kstat', LInputParameters, + LOuputParameters); + + for LIdx := 0 to System.Pred(LOuputParameters.Count) do + begin + LLineOutputInfo := LOuputParameters[LIdx]; + if BeginsWith(LLineOutputInfo, 'chip_id', False) then + begin + LChipId := UInt32(ParseLastInt32(LLineOutputInfo, 0)); + end + else if (BeginsWith(LLineOutputInfo, 'core_id', False)) then + begin + LCoreId := UInt32(ParseLastInt32(LLineOutputInfo, 0)); + end; + + LCoreChipIDs.Add(Format('%u:%u', [LCoreId, LChipId])); + end; + + Result := UInt32(LCoreChipIDs.Count); + + // fallback if above method fails, note: the method below only works only for Solaris 10 and above + if Result < 1 then + begin + LInputParameters.Clear; + LOuputParameters.Clear; + + LInputParameters.Add('-p'); + ExecuteAndParseProcessOutput('psrinfo', LInputParameters, + LOuputParameters); + + Result := UInt32(ParseLastInt32(LOuputParameters.Text, 0)); + end; + + finally + LCoreChipIDs.Free; + LInputParameters.Free; + LOuputParameters.Free; + end; +end; + +class function TNumCPULib.GetTotalPhysicalMemorySolaris(): UInt32; static; +var + LInputParameters, LOuputParameters: TStringList; + LLineOutputInfo,aLastWord: String; + MemoryPages:QWord; + LIdx,LWordCount: Int32; +begin + Result := 0; + + LInputParameters := TStringList.Create(); + LOuputParameters := TStringList.Create(); + try + LInputParameters.Add('-n'); + LInputParameters.Add('system_pages'); + LInputParameters.Add('-p'); + LInputParameters.Add('-s'); + LInputParameters.Add('physmem'); + + + ExecuteAndParseProcessOutput('/usr/bin/kstat', LInputParameters, + LOuputParameters); + + for LIdx := 0 to System.Pred(LOuputParameters.Count) do + begin + LLineOutputInfo := LOuputParameters[LIdx]; + if AnsiStartsText('unix:0:system_pages:physmem',LLineOutputInfo) then + begin + LWordCount:=WordCount(LLineOutputInfo,[' ',#9]); + aLastWord:=ExtractWord(LWordCount,LLineOutputInfo,[' ',#9]); + MemoryPages := QWord(ParseInt32(aLastWord, 0)); + MemoryPages := MemoryPages*4096;//4096 = pagesize + MemoryPages := MemoryPages DIV (1024*1024); + result:=UInt32(MemoryPages); + break; + end + end; + + finally + LInputParameters.Free; + LOuputParameters.Free; + end; +end; + + +{$ENDIF} +// ================================================================// +{$IFDEF NUMCPULIB_GENERIC_BSD} + +class function TNumCPULib.GetLogicalCPUCountGenericBSD(): UInt32; +var + LTempRes: Int32; +begin + LTempRes := sysconf(GetAppropriateSysConfNumber()); + if LTempRes < 1 then + begin + Result := GetLogicalCPUCountUsingSysCtl(); + end + else + begin + Result := UInt32(LTempRes); + end; +end; +{$ENDIF} + +class function TNumCPULib.GetLogicalCPUCount(): UInt32; +begin +{$IF DEFINED(NUMCPULIB_MSWINDOWS)} + Result := GetLogicalCPUCountWindows(); +{$ELSEIF DEFINED(NUMCPULIB_APPLE)} + Result := GetLogicalCPUCountApple(); +{$ELSEIF DEFINED(NUMCPULIB_LINUX)} + Result := GetLogicalCPUCountLinux(); +{$ELSEIF DEFINED(NUMCPULIB_SOLARIS)} + Result := GetLogicalCPUCountSolaris(); +{$ELSEIF DEFINED(NUMCPULIB_GENERIC_BSD)} + Result := GetLogicalCPUCountGenericBSD(); +{$ELSE} + // fallback for other Unsupported Oses + Result := 1; +{$IFEND} +end; + +class function TNumCPULib.GetPhysicalCPUCount(): UInt32; +begin +{$IF DEFINED(NUMCPULIB_MSWINDOWS)} + Result := GetPhysicalCPUCountWindows(); +{$ELSEIF DEFINED(NUMCPULIB_APPLE)} + Result := GetPhysicalCPUCountApple(); +{$ELSEIF DEFINED(NUMCPULIB_LINUX)} + Result := GetPhysicalCPUCountLinux(); +{$ELSEIF DEFINED(NUMCPULIB_SOLARIS)} + Result := GetPhysicalCPUCountSolaris(); +{$ELSE} + // fallback for other Unsupported Oses + Result := 1; +{$IFEND} +end; + +class function TNumCPULib.GetTotalPhysicalMemory(): UInt32; +begin +{$IF DEFINED(NUMCPULIB_MSWINDOWS)} + Result := GetTotalPhysicalMemoryWindows(); +{$ELSEIF DEFINED(NUMCPULIB_APPLE)} + Result := GetTotalPhysicalMemoryApple(); +{$ELSEIF DEFINED(NUMCPULIB_LINUX)} + Result := GetTotalPhysicalMemoryLinux(); +{$ELSEIF DEFINED(NUMCPULIB_SOLARIS)} + Result := GetTotalPhysicalMemorySolaris(); +{$ELSE} + // fallback for other Unsupported Oses + Result := 0; +{$IFEND} +end; + +class function TNumCPULib.GetTotalSwapMemory(): UInt32; +begin +{$IF DEFINED(NUMCPULIB_MSWINDOWS)} + Result := 0; +{$ELSEIF DEFINED(NUMCPULIB_APPLE)} + Result := 0; +{$ELSEIF DEFINED(NUMCPULIB_LINUX)} + Result := GetTotalSwapMemoryLinux(); +{$ELSEIF DEFINED(NUMCPULIB_SOLARIS)} + //Result := GetTotalPhysicalSwapSolaris(); + Result := 0; +{$ELSE} + // fallback for other Unsupported Oses + Result := 0; +{$IFEND} +end; + + +end.