paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-05 23:47:52 +02:00
Code Issues Packages Projects Releases Wiki Activity

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@46977 -
This commit is contained in:
nickysn 2020-09-27 22:18:36 +00:00
commit 38c4c93cee
13 changed files with 1593 additions and 1337 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -18515,9 +18515,11 @@ tests/webtbs/tw3777.pp svneol=native#text/plain
tests/webtbs/tw37779.pp svneol=native#text/pascal
tests/webtbs/tw3778.pp svneol=native#text/plain
tests/webtbs/tw37780.pp svneol=native#text/plain
tests/webtbs/tw37796.pp svneol=native#text/pascal
tests/webtbs/tw3780.pp svneol=native#text/plain
tests/webtbs/tw37806.pp svneol=native#text/pascal
tests/webtbs/tw3782.pp svneol=native#text/plain
tests/webtbs/tw37823.pp svneol=native#text/pascal
tests/webtbs/tw3796.pp svneol=native#text/plain
tests/webtbs/tw3805.pp svneol=native#text/plain
tests/webtbs/tw3814.pp svneol=native#text/plain

79
compiler/aarch64/aoptcpu.pas
View File

@ -43,12 +43,13 @@ Interface
function PostPeepHoleOptsCpu(var p: tai): boolean; override;
function RegLoadedWithNewValue(reg: tregister; hp: tai): boolean;override;
function InstructionLoadsFromReg(const reg: TRegister; const hp: tai): boolean;override;
function LookForPostindexedPattern(p : taicpu) : boolean;
function LookForPostindexedPattern(var p : tai) : boolean;
private
function RemoveSuperfluousFMov(const p: tai; movp: tai; const optimizer: string): boolean;
function OptPass1Shift(var p: tai): boolean;
function OptPostCMP(var p: tai): boolean;
function OptPass1Data(var p: tai): boolean;
function RemoveSuperfluousFMov(const p: tai; movp: tai; const optimizer: string): boolean;
function OptPass1FData(var p: tai): Boolean;
function OptPass1STP(var p: tai): boolean;
function OptPass1Mov(var p: tai): boolean;
function OptPass1FMov(var p: tai): Boolean;
@ -172,20 +173,20 @@ Implementation
ldr/str regX,[reg1], regY/const
}
function TCpuAsmOptimizer.LookForPostindexedPattern(p: taicpu) : boolean;
function TCpuAsmOptimizer.LookForPostindexedPattern(var p: tai) : boolean;
var
hp1 : tai;
begin
Result:=false;
if (p.oper[1]^.typ = top_ref) and
(p.oper[1]^.ref^.addressmode=AM_OFFSET) and
(p.oper[1]^.ref^.index=NR_NO) and
(p.oper[1]^.ref^.offset=0) and
GetNextInstructionUsingReg(p, hp1, p.oper[1]^.ref^.base) and
if (taicpu(p).oper[1]^.typ = top_ref) and
(taicpu(p).oper[1]^.ref^.addressmode=AM_OFFSET) and
(taicpu(p).oper[1]^.ref^.index=NR_NO) and
(taicpu(p).oper[1]^.ref^.offset=0) and
GetNextInstructionUsingReg(p, hp1, taicpu(p).oper[1]^.ref^.base) and
{ we cannot check NR_DEFAULTFLAGS for modification yet so don't allow a condition }
MatchInstruction(hp1, [A_ADD, A_SUB], [PF_None]) and
(taicpu(hp1).oper[0]^.reg=p.oper[1]^.ref^.base) and
(taicpu(hp1).oper[1]^.reg=p.oper[1]^.ref^.base) and
(taicpu(hp1).oper[0]^.reg=taicpu(p).oper[1]^.ref^.base) and
(taicpu(hp1).oper[1]^.reg=taicpu(p).oper[1]^.ref^.base) and
(
{ valid offset? }
(taicpu(hp1).oper[2]^.typ=top_const) and
@ -193,16 +194,20 @@ Implementation
(abs(taicpu(hp1).oper[2]^.val)<256)
) and
{ don't apply the optimization if the base register is loaded }
(getsupreg(p.oper[0]^.reg)<>getsupreg(p.oper[1]^.ref^.base)) and
(getsupreg(taicpu(p).oper[0]^.reg)<>getsupreg(taicpu(p).oper[1]^.ref^.base)) and
not(RegModifiedBetween(taicpu(hp1).oper[0]^.reg,p,hp1)) and
not(RegModifiedBetween(taicpu(hp1).oper[2]^.reg,p,hp1)) then
begin
DebugMsg('Peephole Str/LdrAdd/Sub2Str/Ldr Postindex done', p);
p.oper[1]^.ref^.addressmode:=AM_POSTINDEXED;
if taicpu(hp1).opcode=A_ADD then
p.oper[1]^.ref^.offset:=taicpu(hp1).oper[2]^.val
if taicpu(p).opcode = A_LDR then
DebugMsg('Peephole LdrAdd/Sub2Ldr Postindex done', p)
else
p.oper[1]^.ref^.offset:=-taicpu(hp1).oper[2]^.val;
DebugMsg('Peephole StrAdd/Sub2Str Postindex done', p);
taicpu(p).oper[1]^.ref^.addressmode:=AM_POSTINDEXED;
if taicpu(hp1).opcode=A_ADD then
taicpu(p).oper[1]^.ref^.offset:=taicpu(hp1).oper[2]^.val
else
taicpu(p).oper[1]^.ref^.offset:=-taicpu(hp1).oper[2]^.val;
asml.Remove(hp1);
hp1.Free;
Result:=true;
@ -398,10 +403,17 @@ Implementation
var
hp1: tai;
begin
result:=false;
if GetNextInstructionUsingReg(p, hp1, taicpu(p).oper[0]^.reg) and
RemoveSuperfluousMove(p, hp1, 'DataMov2Data') then
Result:=true;
Result := GetNextInstructionUsingReg(p, hp1, taicpu(p).oper[0]^.reg) and
RemoveSuperfluousMove(p, hp1, 'DataMov2Data');
end;
function TCpuAsmOptimizer.OptPass1FData(var p: tai): Boolean;
var
hp1: tai;
begin
Result := GetNextInstructionUsingReg(p, hp1, taicpu(p).oper[0]^.reg) and
RemoveSuperfluousFMov(p, hp1, 'FOpFMov2FOp');
end;
@ -431,21 +443,20 @@ Implementation
(taicpu(p).oper[2]^.ref^.index=NR_NO) and
(taicpu(p).oper[2]^.ref^.offset=-16) and
(taicpu(p).oper[2]^.ref^.addressmode=AM_PREINDEXED) and
GetNextInstruction(p, hp1) and
GetNextInstruction(hp1, hp2) and
SkipEntryExitMarker(hp2, hp2) and
GetNextInstruction(hp2, hp3) and
SkipEntryExitMarker(hp3, hp3) and
GetNextInstruction(hp3, hp4) and
GetNextInstruction(p, hp1) and
MatchInstruction(hp1, A_MOV, [C_None], [PF_NONE]) and
MatchOperand(taicpu(hp1).oper[0]^,taicpu(p).oper[0]^) and
(taicpu(hp1).oper[1]^.typ = top_reg) and
(taicpu(hp1).oper[1]^.reg = NR_STACK_POINTER_REG) and
GetNextInstruction(hp1, hp2) and
SkipEntryExitMarker(hp2, hp2) and
MatchInstruction(hp2, A_BL, [C_None], [PF_NONE]) and
(taicpu(hp2).oper[0]^.typ = top_ref) and
GetNextInstruction(hp2, hp3) and
SkipEntryExitMarker(hp3, hp3) and
MatchInstruction(hp3, A_LDP, [C_None], [PF_NONE]) and
MatchOpType(taicpu(hp3),top_reg,top_reg,top_ref) and
(taicpu(hp3).oper[0]^.reg = NR_X29) and
@ -455,6 +466,7 @@ Implementation
(taicpu(hp3).oper[2]^.ref^.offset=16) and
(taicpu(hp3).oper[2]^.ref^.addressmode=AM_POSTINDEXED) and
GetNextInstruction(hp3, hp4) and
MatchInstruction(hp4, A_RET, [C_None], [PF_None]) and
(taicpu(hp4).ops = 0) then
begin
@ -728,14 +740,9 @@ Implementation
if p.typ=ait_instruction then
begin
case taicpu(p).opcode of
A_LDR:
begin
Result:=LookForPostindexedPattern(taicpu(p));
end;
A_LDR,
A_STR:
begin
Result:=LookForPostindexedPattern(taicpu(p));
end;
Result:=LookForPostindexedPattern(p);
A_MOV:
Result:=OptPass1Mov(p);
A_STP:
@ -773,11 +780,7 @@ Implementation
A_FNEG,
A_FCVT,
A_FABS:
begin
if GetNextInstructionUsingReg(p, hp1, taicpu(p).oper[0]^.reg) and
RemoveSuperfluousFMov(p, hp1, 'FOpFMov2FOp') then
Result:=true;
end;
Result:=OptPass1FData(p);
A_FMOV:
Result:=OptPass1FMov(p);
else

2692
compiler/arm/aoptcpu.pas
View File

File diff suppressed because it is too large Load Diff

24
compiler/armgen/aoptarm.pas
View File

@ -47,7 +47,7 @@ Type
function OptPass1UXTH(var p: tai): Boolean;
function OptPass1SXTB(var p: tai): Boolean;
function OptPass1SXTH(var p: tai): Boolean;
function OptPass1And(var p: tai): Boolean;
function OptPass1And(var p: tai): Boolean; virtual;
End;
function MatchInstruction(const instr: tai; const op: TCommonAsmOps; const cond: TAsmConds; const postfix: TOpPostfixes): boolean;
@ -170,18 +170,26 @@ Implementation
function TARMAsmOptimizer.GetNextInstructionUsingReg(Current: tai;
Out Next: tai; reg: TRegister): Boolean;
var
gniResult: Boolean;
begin
Next:=Current;
Result := False;
repeat
Result:=GetNextInstruction(Next,Next);
until not (Result) or
not(cs_opt_level3 in current_settings.optimizerswitches) or
(Next.typ<>ait_instruction) or
RegInInstruction(reg,Next) or
is_calljmp(taicpu(Next).opcode)
gniResult:=GetNextInstruction(Next,Next);
if gniResult and RegInInstruction(reg,Next) then
{ Found something }
Exit(True);
until not gniResult or
not(cs_opt_level3 in current_settings.optimizerswitches) or
(Next.typ<>ait_instruction) or
is_calljmp(taicpu(Next).opcode)
{$ifdef ARM}
or RegModifiedByInstruction(NR_PC,Next);
or RegModifiedByInstruction(NR_PC,Next)
{$endif ARM}
;
end;

2
compiler/htypechk.pas
View File

@ -1803,6 +1803,7 @@ implementation
mayberesettypeconvs;
exit;
end;
arrayconstructorn,
setconstn,
stringconstn,
guidconstn :
@ -2106,6 +2107,7 @@ implementation
(tstringdef(def_to).encoding=tstringdef(p.resultdef).encoding) then
eq:=te_equal
end;
formaldef,
setdef :
begin
{ set can also be a not yet converted array constructor }

7
compiler/ncal.pas
View File

@ -1192,6 +1192,13 @@ implementation
(parasym.vardef.typ=setdef) then
inserttypeconv(left,parasym.vardef);
{ if an array constructor can be a set and it is passed to
a formaldef, a set must be passed, see also issue #37796 }
if (left.nodetype=arrayconstructorn) and
(parasym.vardef.typ=formaldef) and
(arrayconstructor_can_be_set(left)) then
left:=arrayconstructor_to_set(left,false);
{ set some settings needed for arrayconstructor }
if is_array_constructor(left.resultdef) then
begin

3
compiler/nflw.pas
View File

@ -2193,7 +2193,8 @@ implementation
p2:=current_procinfo;
while true do
begin
if (p2.flags*[pi_needs_implicit_finally,pi_uses_exceptions,pi_has_implicit_finally])<>[] then
if ((cs_implicit_exceptions in current_settings.moduleswitches) and ((p2.flags*[pi_needs_implicit_finally,pi_has_implicit_finally])<>[])) or
((p2.flags*[pi_uses_exceptions])<>[]) then
Message(cg_e_goto_across_procedures_with_exceptions_not_allowed);
if labelsym.owner=p2.procdef.localst then
break;

4
packages/fcl-passrc/src/pasresolver.pp
View File

@ -16315,7 +16315,7 @@ begin
ParamType,ConstraintClass,ErrorPos);
exit(cIncompatible);
end;
if TPasClassType(ParamType).ObjKind<>okClass then
if not (TPasClassType(ParamType).ObjKind in [okClass,okInterface]) then
begin
if ErrorPos<>nil then
RaiseMsg(20190904175144,nXExpectedButYFound,sXExpectedButYFound,
@ -29830,7 +29830,7 @@ begin
Result:=nil;
while ClassEl<>nil do
begin
if IndexOfImplementedInterface(ClassEl,Intf)>=0 then
if (ClassEl=Intf) or (IndexOfImplementedInterface(ClassEl,Intf)>=0) then
exit(ClassEl);
ClassEl:=GetPasClassAncestor(ClassEl,true) as TPasClassType;
end;

16
packages/pastojs/src/fppas2js.pp
View File

@ -5658,12 +5658,18 @@ begin
else
if not (ConEl is TPasType) then
RaiseNotYetImplemented(20191018180031,ConEl,GetObjPath(Param));
if ConEl is TPasClassType then
begin
if TPasClassType(ConEl).IsExternal then
TIName:=Pas2JSBuiltInNames[pbitnTIExtClass]
TypeEl:=ResolveAliasType(TPasType(ConEl));
if TypeEl is TPasClassType then
case TPasClassType(TypeEl).ObjKind of
okClass:
if TPasClassType(TypeEl).IsExternal then
TIName:=Pas2JSBuiltInNames[pbitnTIExtClass]
else
TIName:=Pas2JSBuiltInNames[pbitnTIClass];
okInterface:
TIName:=Pas2JSBuiltInNames[pbitnTIInterface];
else
TIName:=Pas2JSBuiltInNames[pbitnTIClass];
RaiseNotYetImplemented(20200927100825,ConEl,GetObjPath(Param));
end
else
RaiseNotYetImplemented(20191018180131,ConEl,GetObjPath(Param));

41
packages/pastojs/tests/tcgenerics.pas
View File

@ -52,6 +52,7 @@ type
// class interfaces
procedure TestGen_ClassInterface_Corba;
procedure TestGen_ClassInterface_InterfacedObject;
procedure TestGen_ClassInterface_COM_RTTI;
// statements
Procedure TestGen_InlineSpec_Constructor;
@ -1478,6 +1479,46 @@ begin
'']));
end;
procedure TTestGenerics.TestGen_ClassInterface_COM_RTTI;
begin
StartProgram(true,[supTInterfacedObject]);
Add([
'{$mode delphi}',
'type',
' TBird = class',
' function Fly<T: IInterface>: T;',
' end;',
' IAnt = interface',
' procedure InterfaceProc;',
' end;',
'function TBird.Fly<T>: T;',
'begin',
' if TypeInfo(T)=nil then ;',
'end;',
'var Bird: TBird;',
' Ant: IAnt;',
'begin',
' Ant := Bird.Fly<IAnt>;',
'']);
ConvertProgram;
CheckSource('TestGen_ClassInterface_COM_RTTI',
LinesToStr([ // statements
'rtl.createClass(this, "TBird", pas.system.TObject, function () {',
' this.Fly$G1 = function () {',
' var Result = null;',
' if ($mod.$rtti["IAnt"] === null) ;',
' return Result;',
' };',
'});',
'rtl.createInterface(this, "IAnt", "{B9D0FF27-A446-3A1B-AA85-F167837AA297}", ["InterfaceProc"], pas.system.IUnknown);',
'this.Bird = null;',
'this.Ant = null;',
'']),
LinesToStr([ // $mod.$main
'rtl.setIntfP($mod, "Ant", $mod.Bird.Fly$G1(), true);',
'']));
end;
procedure TTestGenerics.TestGen_InlineSpec_Constructor;
begin
StartProgram(false);

1
rtl/objpas/math.pp
View File

@ -509,6 +509,7 @@ function MaxValue(const data : PInteger; Const N : Integer) : Integer;
{ returns random values with gaussian distribution }
function RandG(mean,stddev : float) : float;
function RandomRange(const aFrom, aTo: Integer): Integer;
function RandomRange(const aFrom, aTo: Int64): Int64;

38
tests/webtbs/tw37796.pp Normal file
View File

@ -0,0 +1,38 @@
program tformal;
{$mode objfpc}
uses
sysutils;
type
TFontStyle = (
fsItalic,
fsBold,
fsUnderlined,
fsStrikeOut
);
TFontStyles = set of TFontStyle;
var aFS: TFontStyles;
procedure Any(const Anything);
begin
aFS:=aFS+TFontStyles(Anything);
Writeln(IntToHex(PLongInt(@Anything)^, 8));
end;
procedure DoIt;
begin
Any([fsItalic, fsBold]); //unit1.pas(31,25) Error: Variable identifier expected
if aFS<>[fsItalic, fsBold] then
halt(1);
Any(Cardinal([fsItalic, fsBold])); //ok
end;
begin
aFS:=[];
writeln(Cardinal(aFS));
DoIt;
writeln(Cardinal(aFS));
writeln('ok');
end.

21
tests/webtbs/tw37823.pp Normal file
View File

@ -0,0 +1,21 @@
{$MODE ISO}
{$implicitExceptions off}
{$Q+}
{$R+}
program gt;
label 1;
procedure jump;
var
a: integer;
b: rawbytestring;
begin
b := 'nanu';
writeln('nanu');
goto 1;
end;
begin
jump;
writeln('not jumped!');
1:
writeln('jumped!');
end.