From 0c2494bec82fe3595b77efa1b55ca38a7c853269 Mon Sep 17 00:00:00 2001 From: svenbarth Date: Wed, 14 Oct 2020 09:11:27 +0000 Subject: [PATCH 1/5] * when setting up the symbol for the SEH data don't check whether it is global, instead check whether it's a function git-svn-id: trunk@47107 - --- compiler/aarch64/agcpugas.pas | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/compiler/aarch64/agcpugas.pas b/compiler/aarch64/agcpugas.pas index 95d4ccebaa..578037e398 100644 --- a/compiler/aarch64/agcpugas.pas +++ b/compiler/aarch64/agcpugas.pas @@ -313,10 +313,11 @@ unit agcpugas; tmplist.free; tmplist:=nil; end; + end; ait_symbol: begin - if tai_symbol(hp).is_global then + if tai_symbol(hp).sym.typ=AT_FUNCTION then lastsym:=tai_symbol(hp); end; ait_instruction: From 5e6ec33a59602b4fb5ecfc9ce6d1ba9ee5d0e03b Mon Sep 17 00:00:00 2001 From: svenbarth Date: Wed, 14 Oct 2020 09:11:32 +0000 Subject: [PATCH 2/5] * reset the stored symbol for SEH data once a new section is encountered git-svn-id: trunk@47108 - --- compiler/aarch64/agcpugas.pas | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/compiler/aarch64/agcpugas.pas b/compiler/aarch64/agcpugas.pas index 578037e398..11e4e74b3d 100644 --- a/compiler/aarch64/agcpugas.pas +++ b/compiler/aarch64/agcpugas.pas @@ -305,7 +305,11 @@ unit agcpugas; internalerror(2020041214); end else - lastsec:=tai_section(hp); + begin + lastsec:=tai_section(hp); + { also reset the last encountered symbol } + lastsym:=nil; + end; if assigned(tmplist) then begin From 7dff106d14e7f9800853e63b4267dfba8f01a91b Mon Sep 17 00:00:00 2001 From: svenbarth Date: Wed, 14 Oct 2020 09:11:37 +0000 Subject: [PATCH 3/5] * use the name of the symbol instead of the name of the section as the later is always lowercased git-svn-id: trunk@47109 - --- compiler/aarch64/agcpugas.pas | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/aarch64/agcpugas.pas b/compiler/aarch64/agcpugas.pas index 11e4e74b3d..a93505a826 100644 --- a/compiler/aarch64/agcpugas.pas +++ b/compiler/aarch64/agcpugas.pas @@ -370,7 +370,7 @@ unit agcpugas; { note: we can pass Nil here, because in case of a LLVM backend this whole code shouldn't be required anyway } - xdatasym:=current_asmdata.DefineAsmSymbol('xdata_'+lastsec.name^,AB_LOCAL,AT_DATA,nil); + xdatasym:=current_asmdata.DefineAsmSymbol('xdata_'+lastsym.sym.name,AB_LOCAL,AT_DATA,nil); tmplist:=tasmlist.create; new_section(tmplist,sec_pdata,lastsec.name^,0); From eb7158d250bd5b395f64ab137d0de787c84ccea8 Mon Sep 17 00:00:00 2001 From: svenbarth Date: Wed, 14 Oct 2020 09:11:44 +0000 Subject: [PATCH 4/5] * ensure that internal method names (namely operator overloads and class con-/destructors) result in different mangled names from ordinary methods even if they should be converted to lowercase (which happens for section names) + added tests git-svn-id: trunk@47110 - --- .gitattributes | 2 ++ compiler/symdef.pas | 9 ++++++++- tests/tbs/tb0679.pp | 28 ++++++++++++++++++++++++++++ tests/tbs/tb0680.pp | 26 ++++++++++++++++++++++++++ 4 files changed, 64 insertions(+), 1 deletion(-) create mode 100644 tests/tbs/tb0679.pp create mode 100644 tests/tbs/tb0680.pp diff --git a/.gitattributes b/.gitattributes index 777874fb21..b235dc559d 100644 --- a/.gitattributes +++ b/.gitattributes @@ -13354,6 +13354,8 @@ tests/tbs/tb0676.pp svneol=native#text/pascal tests/tbs/tb0676a.pp svneol=native#text/plain tests/tbs/tb0677.pp svneol=native#text/pascal tests/tbs/tb0678.pp svneol=native#text/pascal +tests/tbs/tb0679.pp svneol=native#text/pascal +tests/tbs/tb0680.pp svneol=native#text/pascal tests/tbs/ub0060.pp svneol=native#text/plain tests/tbs/ub0069.pp svneol=native#text/plain tests/tbs/ub0119.pp svneol=native#text/plain diff --git a/compiler/symdef.pas b/compiler/symdef.pas index c7c68ff1ef..d638236a4d 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -6795,10 +6795,17 @@ implementation function tprocdef.defaultmangledname: TSymStr; + var + n : TSymStr; begin + n:=procsym.name; + { make sure that the mangled names of these overloadable methods types is + unique even if it's made lowercase (e.g. for section names) } + if proctypeoption in [potype_operator,potype_class_constructor,potype_class_destructor] then + n:='$'+n; { we need to use the symtable where the procsym is inserted, because that is visible to the world } - defaultmangledname:=make_mangledname('',procsym.owner,procsym.name); + defaultmangledname:=make_mangledname('',procsym.owner,n); defaultmangledname:=defaultmangledname+mangledprocparanames(Length(defaultmangledname)) end; diff --git a/tests/tbs/tb0679.pp b/tests/tbs/tb0679.pp new file mode 100644 index 0000000000..9d478152c4 --- /dev/null +++ b/tests/tbs/tb0679.pp @@ -0,0 +1,28 @@ +{ %NORUN } + +program tb0679; + +{$mode objfpc} + +type + TA = class + public + class destructor Destroy; + destructor Destroy; override; + end; + +class destructor TA.Destroy; +begin +end; + +destructor TA.Destroy; +begin + inherited; +end; + +var + A: TA; +begin + A := TA.Create; + A.Free; +end. diff --git a/tests/tbs/tb0680.pp b/tests/tbs/tb0680.pp new file mode 100644 index 0000000000..9af01fbf40 --- /dev/null +++ b/tests/tbs/tb0680.pp @@ -0,0 +1,26 @@ +{ %NORUN } + +program tb0680; + +{$mode objfpc}{$H+} +{$modeswitch advancedrecords} + +type + TTest = record + class operator + (aLeft, aRight: TTest): TTest; + function Plus(aLeft, aRight: TTest): TTest; + end; + +class operator TTest.+(aLeft, aRight: TTest): TTest; +begin + +end; + +function TTest.Plus(aLeft, aRight: TTest): TTest; +begin + +end; + +begin + +end. From 3b0168ae162ff2b7a57aeb9114ad6beb42c8b02b Mon Sep 17 00:00:00 2001 From: florian Date: Wed, 14 Oct 2020 20:08:10 +0000 Subject: [PATCH 5/5] * (slightly) modified (formatting, warning) patch by Jan Bruns to speed up overloading search, resolves #36666 git-svn-id: trunk@47111 - --- compiler/htypechk.pas | 248 +++++++++++++++++++++++++++++++++++++++++- compiler/symdef.pas | 6 + 2 files changed, 253 insertions(+), 1 deletion(-) diff --git a/compiler/htypechk.pas b/compiler/htypechk.pas index 425dec407c..38e2a4af74 100644 --- a/compiler/htypechk.pas +++ b/compiler/htypechk.pas @@ -62,7 +62,10 @@ interface cl6_count, coper_count : integer; { should be signed } ordinal_distance : double; - invalid : boolean; + invalid : boolean; +{$ifndef DISABLE_FAST_OVERLOAD_PATCH} + saved_validity : boolean; +{$endif} wrongparanr : byte; end; @@ -2585,7 +2588,11 @@ implementation { only when the # of parameter are supported by the procedure and it is visible } +{$ifdef DISABLE_FAST_OVERLOAD_PATCH} if (FParalength>=pd.minparacount) and +{$else} + if (pd.seenmarker<>pointer(self)) and (FParalength>=pd.minparacount) and +{$endif} ( ( allowdefaultparas and @@ -2625,6 +2632,7 @@ implementation cpoptions:=cpoptions+[cpo_rtlproc]; found:=false; hp:=FCandidateProcs; +{$ifdef DISABLE_FAST_OVERLOAD_PATCH} while assigned(hp) do begin if (compare_paras(hp^.data.paras,pd.paras,cp_value_equal_const,cpoptions)>=te_equal) and @@ -2636,10 +2644,14 @@ implementation end; hp:=hp^.next; end; +{$endif} if not found then begin proc_add(st,pd,objcidcall); added:=true; +{$ifndef DISABLE_FAST_OVERLOAD_PATCH} + pd.seenmarker:=self; +{$endif} end; end; @@ -2653,6 +2665,14 @@ implementation pd.free; end; end; +{$ifndef DISABLE_FAST_OVERLOAD_PATCH} + {cleanup modified duplicate pd markers} + hp := FCandidateProcs; + while assigned(hp) do begin + hp^.data.seenmarker := nil; + hp := hp^.next; + end; +{$endif} calc_distance(st,objcidcall); @@ -3239,6 +3259,8 @@ implementation end; + + function is_better_candidate(currpd,bestpd:pcandidate):integer; var res : integer; @@ -3489,6 +3511,9 @@ implementation end; + +{$ifdef DISABLE_FAST_OVERLOAD_PATCH} + function tcallcandidates.choose_best(var bestpd:tabstractprocdef; singlevariant: boolean):integer; var pd: tprocdef; @@ -3576,6 +3601,227 @@ implementation end; +{$else} + + function compare_by_old_sortout_check(pd,bestpd:pcandidate):integer; + var cpoptions : tcompare_paras_options; + begin + { don't add duplicates, only compare visible parameters for the user } + cpoptions:=[cpo_ignorehidden]; + if (po_compilerproc in bestpd^.data.procoptions) then + cpoptions:=cpoptions+[cpo_compilerproc]; + if (po_rtlproc in bestpd^.data.procoptions) then + cpoptions:=cpoptions+[cpo_rtlproc]; + + compare_by_old_sortout_check := 0; // can't decide, bestpd probably wasn't sorted out in unpatched + if (compare_paras(pd^.data.paras,bestpd^.data.paras,cp_value_equal_const,cpoptions)>=te_equal) and + (not(po_objc in bestpd^.data.procoptions) or (bestpd^.data.messageinf.str^=pd^.data.messageinf.str^)) then + compare_by_old_sortout_check := 1; // bestpd was sorted out before patch + end; + + function decide_restart(pd,bestpd:pcandidate) : boolean; + begin + decide_restart := false; + if assigned(bestpd) then + begin + { don't restart if bestpd is marked invalid already } + if not bestpd^.invalid then + decide_restart := compare_by_old_sortout_check(pd,bestpd)<>0; + end; + end; + + + procedure save_validity(c : pcandidate); + begin + while assigned(c) do + begin + c^.saved_validity := c^.invalid; + c := c^.next; + end; + end; + + + procedure restore_validity(c : pcandidate); + begin + while assigned(c) do begin + c^.invalid := c^.saved_validity; + c := c^.next; + end; + end; + + + function tcallcandidates.choose_best(var bestpd:tabstractprocdef; singlevariant: boolean):integer; + var + pd: tprocdef; + besthpstart, + hp,hp2 : pcandidate; + cntpd, + res : integer; + restart : boolean; + begin + res:=0; + { + Returns the number of candidates left and the + first candidate is returned in pdbest + } + if not(assigned(FCandidateProcs)) then + begin + choose_best := 0; + exit; + end; + + bestpd:=FCandidateProcs^.data; + if FCandidateProcs^.invalid then + cntpd:=0 + else + cntpd:=1; + + if assigned(FCandidateProcs^.next) then + begin + save_validity(FCandidateProcs); + restart := false; + { keep restarting, until there wasn't a sorted-out besthpstart } + repeat + besthpstart:=FCandidateProcs; + bestpd:=FCandidateProcs^.data; + if restart then + begin + restore_validity(FCandidateProcs); + restart := false; + end; + { Setup the first procdef as best, only count it as a result + when it is valid } + if FCandidateProcs^.invalid then + cntpd:=0 + else + cntpd:=1; + hp:=FCandidateProcs^.next; + while assigned(hp) and not(restart) do + begin + restart := decide_restart(hp,besthpstart); + if not restart then + begin + if not singlevariant then + res:=is_better_candidate(hp,besthpstart) + else + res:=is_better_candidate_single_variant(hp,besthpstart); + end; + if restart then + begin + { mark the sorted out invalid globally } + besthpstart^.saved_validity := true; + end + else if (res>0) then + begin + { hp is better, flag all procs to be incompatible } + while (besthpstart<>hp) do + begin + besthpstart^.invalid:=true; + besthpstart:=besthpstart^.next; + end; + { besthpstart is already set to hp } + bestpd:=besthpstart^.data; + cntpd:=1; + end + else if (res<0) then + begin + { besthpstart is better, flag current hp to be incompatible } + hp^.invalid:=true; + end + else + begin + { res=0, both are valid } + if not hp^.invalid then + inc(cntpd); + end; + hp:=hp^.next; + end; + until not(restart); + end; + + { check the alternate choices if they would have been sorted out before patch... } + + { note we have procadded the candidates, so order is reversed procadd order here. + this was also used above: each sorted-out always has an "outsorter" counterpart + deeper down the next chain + } + + { for the intial implementation, let's first do some more consistency checking} + res := 0; + hp := FCandidateProcs; + while assigned(hp) do + begin + if not(hp^.invalid) then + inc(res); + hp := hp^.next; + end; + if (res<>cntpd) then + internalerror(202002161); + + { check all valid choices for sortout } + cntpd := 0; + hp := FCandidateProcs; + while assigned(hp) do + begin + if not(hp^.invalid) then + begin + hp2 := hp^.next; + while assigned(hp2) do begin + if compare_by_old_sortout_check(hp2,hp)<>0 then + begin + hp^.invalid := true; + hp2 := nil; + end + else + hp2:=hp2^.next; + end; + if not(hp^.invalid) then + begin + inc(cntpd); + { check for the impossible event bestpd had become invalid} + if (cntpd=1) and (hp^.data<>bestpd) then + internalerror(202002162); + end; + end; + hp := hp^.next; + end; + + + { if we've found one, check the procdefs ignored for overload choosing + to see whether they contain one from a child class with the same + parameters (so the overload choosing was not influenced by their + presence, but now that we've decided which overloaded version to call, + make sure we call the version closest in terms of visibility } + if cntpd=1 then + begin + for res:=0 to FIgnoredCandidateProcs.count-1 do + begin + pd:=tprocdef(FIgnoredCandidateProcs[res]); + { stop searching when we start comparing methods of parent of + the struct in which the current best method was found } + if assigned(pd.struct) and + (pd.struct<>tprocdef(bestpd).struct) and + def_is_related(tprocdef(bestpd).struct,pd.struct) then + break; + if (pd.proctypeoption=bestpd.proctypeoption) and + ((pd.procoptions*[po_classmethod,po_methodpointer])=(bestpd.procoptions*[po_classmethod,po_methodpointer])) and + (compare_paras(pd.paras,bestpd.paras,cp_all,[cpo_ignorehidden,cpo_ignoreuniv,cpo_openequalisexact])=te_exact) then + begin + { first one encountered is closest in terms of visibility } + bestpd:=pd; + break; + end; + end; + end; + result:=cntpd; + end; + +{$endif} + + + + + procedure tcallcandidates.find_wrong_para; var currparanr : smallint; diff --git a/compiler/symdef.pas b/compiler/symdef.pas index d638236a4d..67fee52ff0 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -865,6 +865,9 @@ interface a routine that has to be internally generated by the compiler } synthetickind: tsynthetickind; visibility : tvisibility; +{$ifndef DISABLE_FAST_OVERLOAD_PATCH} + seenmarker : pointer; // used for filtering in tcandidate +{$endif} constructor create(level:byte;doregister:boolean);virtual; constructor ppuload(ppufile:tcompilerppufile); destructor destroy;override; @@ -6103,6 +6106,9 @@ implementation {$else symansistr} _mangledname:=nil; {$endif symansistr} +{$ifndef DISABLE_FAST_OVERLOAD_PATCH} + seenmarker := nil; +{$endif} fileinfo:=current_filepos; extnumber:=$ffff; aliasnames:=TCmdStrList.create;