paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-19 05:09:07 +02:00
Code Issues Packages Projects Releases Wiki Activity

# revisions: 45573,45790,45793

Browse Source 
git-svn-id: branches/fixes_3_2@46830 -
This commit is contained in:
marco 2020-09-10 13:57:39 +00:00
parent c47579239a
commit 55b4b54c2a
7 changed files with 124 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
packages/fpmkunit/src/fpmkunit.pp
View File

@ -1682,8 +1682,6 @@ ResourceString
SWarnStartCompilingPackage = 'Start compiling package %s for target %s.';
SWarnCompilingPackagecompleteProgress = '[%3.0f%%] Compiled package %s';
SWarnCompilingPackagecomplete = 'Compiled package %s';
SWarnSkipPackageTargetProgress = '[%3.0f%%] Skipped package %s which has been disabled for target %s';
SWarnSkipPackageTarget = 'Skipped package %s which has been disabled for target %s';
SWarnInstallationPackagecomplete = 'Installation package %s for target %s succeeded';
SWarnCanNotGetAccessRights = 'Warning: Failed to copy access-rights from file %s';
SWarnCanNotSetAccessRights = 'Warning: Failed to copy access-rights to file %s';
@ -1699,6 +1697,8 @@ ResourceString
SWarnRemovedNonEmptyDirectory = 'Warning: Removed non empty directory "%s"';
SInfoPackageAlreadyProcessed = 'Package %s is already processed';
SInfoSkipPackageTargetProgress = '[%3.0f%%] Skipped package %s which has been disabled for target %s';
SInfoSkipPackageTarget = 'Skipped package %s which has been disabled for target %s';
SInfoCompilingTarget = 'Compiling target %s';
SInfoExecutingCommand = 'Executing command "%s %s"';
SInfoCreatingOutputDir = 'Creating output dir "%s"';
@ -8158,7 +8158,7 @@ procedure TBuildEngine.Compile(Packages: TPackages);
else
begin
inc(FProgressCount);
log(vlWarning,SWarnSkipPackageTargetProgress,[(FProgressCount)/FProgressMax * 100, APackage.Name, Defaults.Target]);
log(vlInfo,SInfoSkipPackageTargetProgress,[(FProgressCount)/FProgressMax * 100, APackage.Name, Defaults.Target]);
APackage.FTargetState:=tsNoCompile;
end;
end;
@ -8167,7 +8167,7 @@ procedure TBuildEngine.Compile(Packages: TPackages);
Var
I : integer;
{$ifndef NO_THREADING}
Thr : Integer;
Thr, ThreadCount : Integer;
Finished : boolean;
ErrorState: boolean;
ErrorMessage: string;
@ -8197,7 +8197,7 @@ Var
else // A problem occurred, stop the compilation
begin
ErrorState:=true;
ErrorMessage:=AThread.ErrorMessage;
ErrorMessage:='Error inside worker thread for package '+Athread.APackage.Name+': '+AThread.ErrorMessage;
Finished:=true;
end;
AThread.APackage := nil;
@ -8251,7 +8251,7 @@ begin
else
begin
inc(FProgressCount);
log(vlWarning,SWarnSkipPackageTargetProgress,[(FProgressCount)/FProgressMax * 100, P.Name, Defaults.Target]);
log(vlInfo,SInfoSkipPackageTargetProgress,[(FProgressCount)/FProgressMax * 100, P.Name, Defaults.Target]);
end;
end;
end
@ -8262,34 +8262,71 @@ begin
ErrorState := False;
Finished := False;
I := 0;
ThreadCount:=0;
// This event is set by the worker-threads to notify the main/this thread
// that a package finished it's task.
NotifyThreadWaiting := RTLEventCreate;
SetLength(Threads,Defaults.ThreadsAmount);
// Create all worker-threads
for Thr:=0 to Defaults.ThreadsAmount-1 do
Threads[Thr] := TCompileWorkerThread.Create(self,NotifyThreadWaiting);
try
// When a thread notifies this thread that it is ready, loop on all
// threads to check their state and if possible assign a new package
// to them to compile.
while not Finished do
begin
RTLeventWaitFor(NotifyThreadWaiting);
for Thr:=0 to Defaults.ThreadsAmount-1 do if not Finished then
ProcessThreadResult(Threads[Thr]);
end;
// Compilation finished or aborted. Wait for all threads to end.
for thr:=0 to Defaults.ThreadsAmount-1 do
begin
Threads[Thr].Terminate;
RTLeventSetEvent(Threads[Thr].NotifyStartTask);
Threads[Thr].WaitFor;
end;
try
// Create all worker-threads
try
for Thr:=0 to Defaults.ThreadsAmount-1 do
begin
Threads[Thr] := TCompileWorkerThread.Create(self,NotifyThreadWaiting);
if assigned(Threads[Thr]) then
inc(ThreadCount);
end;
except
on E: Exception do
begin
ErrorMessage := E.Message;
ErrorState:=true;
end;
end;
try
// When a thread notifies this thread that it is ready, loop on all
// threads to check their state and if possible assign a new package
// to them to compile.
while not Finished do
begin
RTLeventWaitFor(NotifyThreadWaiting);
for Thr:=0 to Defaults.ThreadsAmount-1 do
if assigned(Threads[Thr]) and not Finished then
ProcessThreadResult(Threads[Thr]);
end;
except
on E: Exception do
begin
if not ErrorState then
ErrorMessage := E.Message;
ErrorState:=true;
end;
end;
try
// Compilation finished or aborted. Wait for all threads to end.
for thr:=0 to Defaults.ThreadsAmount-1 do
if assigned(Threads[Thr]) then
begin
Threads[Thr].Terminate;
RTLeventSetEvent(Threads[Thr].NotifyStartTask);
Threads[Thr].WaitFor;
end;
except
on E: Exception do
begin
if not ErrorState then
ErrorMessage := E.Message;
ErrorState:=true;
end;
end;
finally
RTLeventdestroy(NotifyThreadWaiting);
for thr:=0 to Defaults.ThreadsAmount-1 do
Threads[Thr].Free;
if assigned(Threads[Thr]) then
begin
Threads[Thr].Free;
dec(ThreadCount);
end;
end;
if ErrorState then
raise Exception.Create(ErrorMessage);
@ -8314,7 +8351,7 @@ begin
log(vlWarning, SWarnInstallationPackagecomplete, [P.Name, Defaults.Target]);
end
else
log(vlWarning,SWarnSkipPackageTarget,[P.Name, Defaults.Target]);
log(vlInfo,SInfoSkipPackageTarget,[P.Name, Defaults.Target]);
end;
NotifyEventCollection.CallEvents(neaAfterInstall, Self);
end;
@ -8343,7 +8380,7 @@ begin
log(vlWarning, SWarnInstallationPackagecomplete, [P.Name, Defaults.Target]);
end
else
log(vlWarning,SWarnSkipPackageTarget,[P.Name, Defaults.Target]);
log(vlInfo,SInfoSkipPackageTarget,[P.Name, Defaults.Target]);
end;
finally
FinishArchive(P);

8
packages/rtl-objpas/src/inc/dateutil.inc
View File

@ -1390,9 +1390,11 @@ end;
Function DaysBetween(const ANow, AThen: TDateTime): Integer;
begin
Result:=Trunc(Abs(DateTimeDiff(ANow,AThen))+HalfMilliSecond);
end;
if anow>athen then
Result:=Trunc(Abs(DateTimeDiff(ANow,AThen))+HalfMilliSecond)
else
Result:=Trunc(Abs(DateTimeDiff(AThen,ANow))+HalfMilliSecond); // bug 37361
end;
Function HoursBetween(const ANow, AThen: TDateTime): Int64;
begin

11
rtl/i386/cpu.pp
View File

@ -35,6 +35,7 @@ unit cpu;
function AVXSupport: boolean;inline;
function AVX2Support: boolean;inline;
function FMASupport: boolean;inline;
function POPCNTSupport: boolean;inline;
var
is_sse3_cpu : boolean = false;
@ -48,7 +49,8 @@ unit cpu;
_AVXSupport,
_AVX2Support,
_AESSupport,
_FMASupport : boolean;
_FMASupport,
_POPCNTSupport : boolean;
function InterlockedCompareExchange128(var Target: Int128Rec; NewValue: Int128Rec; Comperand: Int128Rec): Int128Rec;
@ -123,6 +125,7 @@ unit cpu;
popl %ebx
end;
_AESSupport:=(_ecx and $2000000)<>0;
_POPCNTSupport:=(_ecx and $800000)<>0;
_AVXSupport:=
{ XGETBV suspport? }
@ -179,6 +182,12 @@ unit cpu;
result:=_FMASupport;
end;
function POPCNTSupport: boolean;inline;
begin
result:=_POPCNTSupport;
end;
begin
SetupSupport;
end.

64
rtl/inc/varianth.inc
View File

@ -17,52 +17,52 @@
{ Variant types. Changes to these consts must be synchronized with
similar list in compiler code, in implementation part of symdef.pas }
const
varempty = 0;
varnull = 1;
varsmallint = 2;
varinteger = 3;
varEmpty = 0;
varNull = 1;
varSmallInt = 2;
varInteger = 3;
{$ifndef FPUNONE}
varsingle = 4;
vardouble = 5;
vardate = 7;
varSingle = 4;
varDouble = 5;
varDate = 7;
{$endif}
varcurrency = 6;
varolestr = 8;
vardispatch = 9;
varerror = 10;
varboolean = 11;
varvariant = 12;
varunknown = 13;
vardecimal = 14;
varshortint = 16;
varbyte = 17;
varword = 18;
varlongword = 19;
varint64 = 20;
varqword = 21;
varCurrency = 6;
varOleStr = 8;
varDispatch = 9;
varError = 10;
varBoolean = 11;
varVariant = 12;
varUnknown = 13;
varDecimal = 14;
varShortInt = 16;
varByte = 17;
varWord = 18;
varLongWord = 19;
varInt64 = 20;
varQWord = 21;
varrecord = 36;
varRecord = 36;
{ The following values never appear as TVarData.VType, but are used in
TCallDesc.Args[] as aliases for compiler-specific types.
(since it provides only 1 byte per element, actual values won't fit)
The choice of values is pretty much arbitrary. }
varstrarg = $48; { maps to varstring }
varustrarg = $49; { maps to varustring }
varStrArg = $48; { maps to varstring }
varUStrArg = $49; { maps to varustring }
{ Compiler-specific variant types (not known to COM) are kept in
'pseudo-custom' range of $100-$10E. Real custom types start with $10F. }
varstring = $100;
varany = $101;
varustring = $102;
vartypemask = $fff;
vararray = $2000;
varbyref = $4000;
varString = $100;
varAny = $101;
varUString = $102;
varTypeMask = $fff;
varArray = $2000;
varByRef = $4000;
varword64 = varqword;
varuint64 = varqword; // Delphi alias
varWord64 = varQWord;
varUInt64 = varQWord; // Delphi alias
type
tvartype = word;

2
rtl/objpas/classes/stringl.inc
View File

@ -249,7 +249,7 @@ begin
Result:=Result+Delimiter;
end;
// Quote empty string:
If (Length(Result)=0) and (Count=1) then
If (Length(Result)=0) and (Count=1) and (QuoteChar<>#0) then
Result:=QuoteChar+QuoteChar;
end;

2
rtl/objpas/sysutils/filutilh.inc
View File

@ -162,7 +162,7 @@ Const
fsFromEnd = 2;
{ File errors }
feInvalidHandle : THandle = THandle(-1); //return value on FileOpen error
feInvalidHandle = THandle(-1); //return value on FileOpen error
Type
TFileSearchOption = (sfoImplicitCurrentDir,sfoStripQuotes);

10
rtl/x86_64/cpu.pp
View File

@ -33,6 +33,7 @@ unit cpu;
function AVXSupport : boolean;inline;
function AVX2Support: boolean;inline;
function FMASupport: boolean;inline;
function POPCNTSupport: boolean;inline;
var
is_sse3_cpu : boolean = false;
@ -48,7 +49,8 @@ unit cpu;
_AVXSupport,
_InterlockedCompareExchange128Support,
_AVX2Support,
_FMASupport : boolean;
_FMASupport,
_POPCNTSupport: boolean;
function InterlockedCompareExchange128(var Target: Int128Rec; NewValue: Int128Rec; Comperand: Int128Rec): Int128Rec; assembler;
{
@ -141,6 +143,7 @@ unit cpu;
end ['rax','rbx','rcx','rdx'];
_InterlockedCompareExchange128Support:=(_ecx and $2000)<>0;
_AESSupport:=(_ecx and $2000000)<>0;
_POPCNTSupport:=(_ecx and $800000)<>0;
_AVXSupport:=
{ XGETBV suspport? }
@ -194,6 +197,11 @@ unit cpu;
end;
function POPCNTSupport: boolean;inline;
begin
result:=_POPCNTSupport;
end;
begin
SetupSupport;
end.