From 7adcd2a8a27ff89558856756c8f7abd002623d88 Mon Sep 17 00:00:00 2001 From: michael Date: Tue, 5 Jan 2021 09:20:45 +0000 Subject: [PATCH 1/6] * Fix memleak when using packages git-svn-id: trunk@48082 - --- packages/fcl-passrc/src/pparser.pp | 3 +++ 1 file changed, 3 insertions(+) diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index 1e8a23c240..59e54088b1 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -3142,7 +3142,10 @@ begin FinishedModule; finally if HasFinished then + begin + Module.Release{$IFDEF CheckPasTreeRefCount}('TPasPackage.Modules'){$ENDIF}; FCurModule:=nil; // clear module if there is an error or finished parsing + end; end; end; From b31305810c4b859baa6238de5168fae0c174b3c5 Mon Sep 17 00:00:00 2001 From: michael Date: Tue, 5 Jan 2021 09:21:25 +0000 Subject: [PATCH 2/6] * print context in Release in debug mode git-svn-id: trunk@48083 - --- packages/fcl-passrc/src/pastree.pp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/packages/fcl-passrc/src/pastree.pp b/packages/fcl-passrc/src/pastree.pp index 709090d435..5fd41c8701 100644 --- a/packages/fcl-passrc/src/pastree.pp +++ b/packages/fcl-passrc/src/pastree.pp @@ -3100,7 +3100,7 @@ begin CN:=CN+' '+IntToStr(FRefCount); //If Assigned(Parent) then // CN:=CN+' ('+Parent.ClassName+')'; - Writeln('TPasElement.Release : ',Cn); + Writeln('TPasElement.Release : ',Cn,' at ',aId); {AllowWriteln-} {$endif} {$IFDEF CheckPasTreeRefCount} @@ -3136,7 +3136,7 @@ begin Dec(FGlobalRefCount); {$endif} end; -{$if defined(debugrefcount) or defined(VerbosePasTreeMem)} Writeln('TPasElement.Released : ',Cn); {$endif} +{$if defined(debugrefcount) or defined(VerbosePasTreeMem)} Writeln('TPasElement.Released : ',Cn,' at ',aID); {$endif} end; procedure TPasElement.ForEachCall(const aMethodCall: TOnForEachPasElement; From 28efcfba65295ebf1b88238906b79594fe54fda4 Mon Sep 17 00:00:00 2001 From: florian Date: Tue, 5 Jan 2021 15:15:41 +0000 Subject: [PATCH 3/6] + patch by J. Gareth Moreton: Advanced MOVZX optimisations, resolves #38294 git-svn-id: trunk@48086 - --- compiler/i386/aoptcpu.pas | 8 +- compiler/x86/aoptx86.pas | 704 +++++++++++++++++++++++++++++++++++- compiler/x86_64/aoptcpu.pas | 4 + 3 files changed, 713 insertions(+), 3 deletions(-) diff --git a/compiler/i386/aoptcpu.pas b/compiler/i386/aoptcpu.pas index 1ce465b136..c6b667525e 100644 --- a/compiler/i386/aoptcpu.pas +++ b/compiler/i386/aoptcpu.pas @@ -252,6 +252,8 @@ unit aoptcpu; Result:=OptPass2Jmp(p); A_MOV: Result:=OptPass2MOV(p); + A_MOVZX: + Result:=OptPass2Movx(p); A_SUB: Result:=OptPass2SUB(p); else @@ -288,7 +290,9 @@ unit aoptcpu; { "cmpl $3,%eax; movzbl 8(%ebp),%ebx; je .Lxxx" } { so we can't safely replace the movzx then with xor/mov, } { since that would change the flags (JM) } - if not(cs_opt_regvar in current_settings.optimizerswitches) then + if PostPeepholeOptMovzx(p) then + Result := True + else if not(cs_opt_regvar in current_settings.optimizerswitches) then begin if (taicpu(p).oper[1]^.typ = top_reg) then if (taicpu(p).oper[0]^.typ = top_reg) @@ -340,6 +344,8 @@ unit aoptcpu; Result:=PostPeepholeOptAnd(p); A_MOVSX: Result:=PostPeepholeOptMOVSX(p); + A_SHR: + Result:=PostPeepholeOptShr(p); else ; end; diff --git a/compiler/x86/aoptx86.pas b/compiler/x86/aoptx86.pas index 9e2dac7e05..4b38629c44 100644 --- a/compiler/x86/aoptx86.pas +++ b/compiler/x86/aoptx86.pas @@ -140,6 +140,7 @@ unit aoptx86; function OptPass1VPXor(var p: tai): boolean; function OptPass1Imul(var p : tai) : boolean; + function OptPass2Movx(var p : tai): Boolean; function OptPass2MOV(var p : tai) : boolean; function OptPass2Imul(var p : tai) : boolean; function OptPass2Jmp(var p : tai) : boolean; @@ -149,8 +150,8 @@ unit aoptx86; function OptPass2ADD(var p : tai): Boolean; function PostPeepholeOptMov(var p : tai) : Boolean; -{$ifdef x86_64} { These post-peephole optimisations only affect 64-bit registers. [Kit] } function PostPeepholeOptMovzx(var p : tai) : Boolean; +{$ifdef x86_64} { These post-peephole optimisations only affect 64-bit registers. [Kit] } function PostPeepholeOptXor(var p : tai) : Boolean; {$endif} function PostPeepholeOptAnd(var p : tai) : boolean; @@ -160,6 +161,7 @@ unit aoptx86; function PostPeepholeOptCall(var p : tai) : Boolean; function PostPeepholeOptLea(var p : tai) : Boolean; function PostPeepholeOptPush(var p: tai): Boolean; + function PostPeepholeOptShr(var p : tai) : boolean; procedure ConvertJumpToRET(const p: tai; const ret_p: tai); @@ -4935,6 +4937,529 @@ unit aoptx86; end; + function TX86AsmOptimizer.OptPass2Movx(var p : tai) : boolean; + const + LIST_STEP_SIZE = 4; + var + ThisReg: TRegister; + MinSize, MaxSize, TrySmaller, TargetSize: TOpSize; + TargetSubReg: TSubRegister; + hp1, hp2: tai; + RegInUse, p_removed: Boolean; + + { Store list of found instructions so we don't have to call + GetNextInstructionUsingReg multiple times } + InstrList: array of taicpu; + InstrMax, Index: Integer; + UpperLimit, TrySmallerLimit: TCgInt; + + { Data flow analysis } + TestValMin, TestValMax: TCgInt; + SmallerOverflow: Boolean; + + begin + Result := False; + p_removed := False; + + { This is anything but quick! } + if not(cs_opt_level2 in current_settings.optimizerswitches) then + Exit; + + SetLength(InstrList, 0); + InstrMax := -1; + ThisReg := taicpu(p).oper[1]^.reg; + hp1 := p; + + case taicpu(p).opsize of + S_BW, S_BL: + begin + UpperLimit := $FF; + MinSize := S_B; + if taicpu(p).opsize = S_BW then + MaxSize := S_W + else + MaxSize := S_L; + end; + S_WL: + begin + UpperLimit := $FFFF; + MinSize := S_W; + MaxSize := S_L; + end + else + InternalError(2020112301); + end; + + TestValMin := 0; + TestValMax := UpperLimit; + TrySmallerLimit := UpperLimit; + TrySmaller := S_NO; + SmallerOverflow := False; + + while GetNextInstructionUsingReg(hp1, hp1, ThisReg) and + (hp1.typ = ait_instruction) and + ( + { Under -O1 and -O2, GetNextInstructionUsingReg may return an + instruction that doesn't actually contain ThisReg } + (cs_opt_level3 in current_settings.optimizerswitches) or + RegInInstruction(ThisReg, hp1) + ) do + begin + case taicpu(hp1).opcode of + A_INC,A_DEC: + begin + { Has to be an exact match on the register } + if not MatchOperand(taicpu(hp1).oper[0]^, ThisReg) then + Break; + + if taicpu(hp1).opcode = A_INC then + begin + Inc(TestValMin); + Inc(TestValMax); + end + else + begin + Dec(TestValMin); + Dec(TestValMax); + end; + end; + + { OR and XOR are not included because they can too easily fool + the data flow analysis (they can cause non-linear behaviour) } + A_ADD,A_SUB,A_AND,A_SHL,A_SHR: + begin + if + (taicpu(hp1).oper[1]^.typ <> top_reg) or + { Has to be an exact match on the register } + (taicpu(hp1).oper[1]^.reg <> ThisReg) or not + ( + ( + (taicpu(hp1).oper[0]^.typ = top_const) and + ( + ( + (taicpu(hp1).opcode = A_SHL) and + ( + ((MinSize = S_B) and (taicpu(hp1).oper[0]^.val < 8)) or + ((MinSize = S_W) and (taicpu(hp1).oper[0]^.val < 16)) or + ((MinSize = S_L) and (taicpu(hp1).oper[0]^.val < 32)) + ) + ) or ( + (taicpu(hp1).opcode <> A_SHL) and + ( + ((taicpu(hp1).oper[0]^.val and UpperLimit) = taicpu(hp1).oper[0]^.val) or + { Is it in the negative range? } + (((not taicpu(hp1).oper[0]^.val) and (UpperLimit shr 1)) = (not taicpu(hp1).oper[0]^.val)) + ) + ) + ) + ) or ( + MatchOperand(taicpu(hp1).oper[0]^, taicpu(hp1).oper[1]^.reg) and + ((taicpu(hp1).opcode = A_ADD) or (taicpu(hp1).opcode = A_AND) or (taicpu(hp1).opcode = A_SUB)) + ) + ) then + Break; + + case taicpu(hp1).opcode of + A_ADD: + if (taicpu(hp1).oper[0]^.typ = top_reg) then + begin + TestValMin := TestValMin * 2; + TestValMax := TestValMax * 2; + end + else + begin + TestValMin := TestValMin + taicpu(hp1).oper[0]^.val; + TestValMax := TestValMax + taicpu(hp1).oper[0]^.val; + end; + A_SUB: + if (taicpu(hp1).oper[0]^.typ = top_reg) then + begin + TestValMin := 0; + TestValMax := 0; + end + else + begin + TestValMin := TestValMin - taicpu(hp1).oper[0]^.val; + TestValMax := TestValMax - taicpu(hp1).oper[0]^.val; + end; + A_AND: + if (taicpu(hp1).oper[0]^.typ = top_const) then + begin + { we might be able to go smaller if AND appears first } + if InstrMax = -1 then + case MinSize of + S_B: + ; + S_W: + if ((taicpu(hp1).oper[0]^.val and $FF) = taicpu(hp1).oper[0]^.val) or + ((not(taicpu(hp1).oper[0]^.val) and $7F) = (not taicpu(hp1).oper[0]^.val)) then + begin + TrySmaller := S_B; + TrySmallerLimit := $FF; + end; + S_L: + if ((taicpu(hp1).oper[0]^.val and $FF) = taicpu(hp1).oper[0]^.val) or + ((not(taicpu(hp1).oper[0]^.val) and $7F) = (not taicpu(hp1).oper[0]^.val)) then + begin + TrySmaller := S_B; + TrySmallerLimit := $FF; + end + else if ((taicpu(hp1).oper[0]^.val and $FFFF) = taicpu(hp1).oper[0]^.val) or + ((not(taicpu(hp1).oper[0]^.val) and $7FFF) = (not taicpu(hp1).oper[0]^.val)) then + begin + TrySmaller := S_W; + TrySmallerLimit := $FFFF; + end; + else + InternalError(2020112320); + end; + + TestValMin := TestValMin and taicpu(hp1).oper[0]^.val; + TestValMax := TestValMax and taicpu(hp1).oper[0]^.val; + end; + A_SHL: + begin + TestValMin := TestValMin shl taicpu(hp1).oper[0]^.val; + TestValMax := TestValMax shl taicpu(hp1).oper[0]^.val; + end; + A_SHR: + begin + { we might be able to go smaller if SHR appears first } + if InstrMax = -1 then + case MinSize of + S_B: + ; + S_W: + if (taicpu(hp1).oper[0]^.val >= 8) then + begin + TrySmaller := S_B; + TrySmallerLimit := $FF; + end; + S_L: + if (taicpu(hp1).oper[0]^.val >= 24) then + begin + TrySmaller := S_B; + TrySmallerLimit := $FF; + end + else if (taicpu(hp1).oper[0]^.val >= 16) then + begin + TrySmaller := S_W; + TrySmallerLimit := $FFFF; + end; + else + InternalError(2020112321); + end; + + TestValMin := TestValMin shr taicpu(hp1).oper[0]^.val; + TestValMax := TestValMax shr taicpu(hp1).oper[0]^.val; + end; + else + InternalError(2020112303); + end; + end; +(* + A_IMUL: + case taicpu(hp1).ops of + 2: + begin + if not MatchOpType(hp1, top_reg, top_reg) or + { Has to be an exact match on the register } + (taicpu(hp1).oper[0]^.reg <> ThisReg) or + (taicpu(hp1).oper[1]^.reg <> ThisReg) then + Break; + + TestValMin := TestValMin * TestValMin; + TestValMax := TestValMax * TestValMax; + end; + 3: + begin + if not MatchOpType(hp1, top_const, top_reg, top_reg) or + { Has to be an exact match on the register } + (taicpu(hp1).oper[1]^.reg <> ThisReg) or + (taicpu(hp1).oper[2]^.reg <> ThisReg) or + ((taicpu(hp1).oper[0]^.val and UpperLimit) = taicpu(hp1).oper[0]^.val) or + { Is it in the negative range? } + (((not taicpu(hp1).oper[0]^.val) and (UpperLimit shr 1)) = (not taicpu(hp1).oper[0]^.val)) then + Break; + + TestValMin := TestValMin * taicpu(hp1).oper[0]^.val; + TestValMax := TestValMax * taicpu(hp1).oper[0]^.val; + end; + else + Break; + end; + + A_IDIV: + case taicpu(hp1).ops of + 3: + begin + if not MatchOpType(hp1, top_const, top_reg, top_reg) or + { Has to be an exact match on the register } + (taicpu(hp1).oper[1]^.reg <> ThisReg) or + (taicpu(hp1).oper[2]^.reg <> ThisReg) or + ((taicpu(hp1).oper[0]^.val and UpperLimit) = taicpu(hp1).oper[0]^.val) or + { Is it in the negative range? } + (((not taicpu(hp1).oper[0]^.val) and (UpperLimit shr 1)) = (not taicpu(hp1).oper[0]^.val)) then + Break; + + TestValMin := TestValMin div taicpu(hp1).oper[0]^.val; + TestValMax := TestValMax div taicpu(hp1).oper[0]^.val; + end; + else + Break; + end; +*) + A_MOVZX: + begin + if not MatchOpType(taicpu(hp1), top_reg, top_reg) then + Break; + + { The objective here is to try to find a combination that + removes one of the MOV/Z instructions. } + case taicpu(hp1).opsize of + S_WL: + if (MinSize in [S_B, S_W]) then + begin + TargetSize := S_L; + TargetSubReg := R_SUBD; + end + else if ((TrySmaller in [S_B, S_W]) and not SmallerOverflow) then + begin + TargetSize := TrySmaller; + if TrySmaller = S_B then + TargetSubReg := R_SUBL + else + TargetSubReg := R_SUBW; + end + else + Break; + + S_BW: + if (MinSize in [S_B, S_W]) then + begin + TargetSize := S_W; + TargetSubReg := R_SUBW; + end + else if ((TrySmaller = S_B) and not SmallerOverflow) then + begin + TargetSize := S_B; + TargetSubReg := R_SUBL; + end + else + Break; + + S_BL: + if (MinSize in [S_B, S_W]) then + begin + TargetSize := S_L; + TargetSubReg := R_SUBD; + end + else if ((TrySmaller = S_B) and not SmallerOverflow) then + begin + TargetSize := S_B; + TargetSubReg := R_SUBL; + end + else + Break; + + else + InternalError(2020112302); + end; + + { Update the register to its new size } + ThisReg := newreg(R_INTREGISTER, getsupreg(ThisReg), TargetSubReg); + + if TargetSize = MinSize then + begin + { Convert the input MOVZX to a MOV } + if (taicpu(p).oper[0]^.typ = top_reg) and + SuperRegistersEqual(taicpu(p).oper[0]^.reg, ThisReg) then + begin + { Or remove it completely! } + DebugMsg(SPeepholeOptimization + 'Movzx2Nop 1', p); + RemoveCurrentP(p); + p_removed := True; + end + else + begin + DebugMsg(SPeepholeOptimization + 'Movzx2Mov 1', p); + taicpu(p).opcode := A_MOV; + taicpu(p).oper[1]^.reg := ThisReg; + taicpu(p).opsize := TargetSize; + end; + + Result := True; + end + else if TargetSize <> MaxSize then + begin + + case MaxSize of + S_L: + if TargetSize = S_W then + begin + DebugMsg(SPeepholeOptimization + 'movzbl2movzbw', p); + taicpu(p).opsize := S_BW; + taicpu(p).oper[1]^.reg := ThisReg; + Result := True; + end + else + InternalError(2020112341); + + S_W: + if TargetSize = S_L then + begin + DebugMsg(SPeepholeOptimization + 'movzbw2movzbl', p); + taicpu(p).opsize := S_BL; + taicpu(p).oper[1]^.reg := ThisReg; + Result := True; + end + else + InternalError(2020112342); + else + ; + end; + end; + + + if (MaxSize = TargetSize) or + ((TargetSize = S_L) and (taicpu(hp1).opsize in [S_L, S_BL, S_WL])) or + ((TargetSize = S_W) and (taicpu(hp1).opsize in [S_W, S_BW])) then + begin + { Convert the output MOVZX to a MOV } + if (taicpu(hp1).oper[0]^.typ = top_reg) and + SuperRegistersEqual(taicpu(hp1).oper[1]^.reg, ThisReg) then + begin + { Or remove it completely! } + DebugMsg(SPeepholeOptimization + 'Movzx2Nop 2', hp1); + + { Be careful; if p = hp1 and p was also removed, p + will become a dangling pointer } + if p = hp1 then + RemoveCurrentp(p) { p = hp1 and will then become the next instruction } + else + RemoveInstruction(hp1); + end + else + begin + taicpu(hp1).opcode := A_MOV; + taicpu(hp1).oper[0]^.reg := ThisReg; + taicpu(hp1).opsize := TargetSize; + + { Check to see if the active register is used afterwards; + if not, we can change it and make a saving. } + RegInUse := False; + TransferUsedRegs(TmpUsedRegs); + + { The target register may be marked as in use to cross + a jump to a distant label, so exclude it } + ExcludeRegFromUsedRegs(taicpu(hp1).oper[1]^.reg, TmpUsedRegs); + + hp2 := p; + repeat + + UpdateUsedRegs(TmpUsedRegs, tai(hp2.next)); + + { Explicitly check for the excluded register (don't include the first + instruction as it may be reading from here } + if ((p <> hp2) and (RegInInstruction(taicpu(hp1).oper[1]^.reg, hp2))) or + RegInUsedRegs(taicpu(hp1).oper[1]^.reg, TmpUsedRegs) then + begin + RegInUse := True; + Break; + end; + + if not GetNextInstruction(hp2, hp2) then + InternalError(2020112340); + + until (hp2 = hp1); + + if not RegInUse and not RegUsedAfterInstruction(ThisReg, hp1, TmpUsedRegs) then + begin + DebugMsg(SPeepholeOptimization + 'Simplified register usage so ' + debug_regname(taicpu(hp1).oper[1]^.reg) + ' = ' + debug_regname(taicpu(p).oper[1]^.reg), p); + ThisReg := taicpu(hp1).oper[1]^.reg; + + TransferUsedRegs(TmpUsedRegs); + AllocRegBetween(ThisReg, p, hp1, TmpUsedRegs); + + DebugMsg(SPeepholeOptimization + 'Movzx2Nop 3', hp1); + if p = hp1 then + RemoveCurrentp(p) { p = hp1 and will then become the next instruction } + else + RemoveInstruction(hp1); + + { Instruction will become "mov %reg,%reg" } + if not p_removed and (taicpu(p).opcode = A_MOV) and + MatchOperand(taicpu(p).oper[0]^, ThisReg) then + begin + DebugMsg(SPeepholeOptimization + 'Movzx2Nop 6', p); + RemoveCurrentP(p); + p_removed := True; + end + else + taicpu(p).oper[1]^.reg := ThisReg; + + Result := True; + end + else + DebugMsg(SPeepholeOptimization + 'Movzx2Mov 2', hp1); + + end; + end + else + InternalError(2020112330); + + { Now go through every instruction we found and change the + size. If TargetSize = MaxSize, then almost no changes are + needed and Result can remain False if it hasn't been set + yet. } + + if (TargetSize <> MaxSize) and (InstrMax >= 0) then + begin + for Index := 0 to InstrMax do + begin + + { If p_removed is true, then the original MOV/Z was removed + and removing the AND instruction may not be safe if it + appears first } + if (InstrList[Index].oper[InstrList[Index].ops - 1]^.typ <> top_reg) then + InternalError(2020112310); + + if InstrList[Index].oper[0]^.typ = top_reg then + InstrList[Index].oper[0]^.reg := ThisReg; + + InstrList[Index].oper[InstrList[Index].ops - 1]^.reg := ThisReg; + InstrList[Index].opsize := TargetSize; + end; + + Result := True; + end; + + Exit; + end; + + else + { This includes ADC, SBB, IDIV and SAR } + Break; + end; + + if (TestValMin < 0) or (TestValMax < 0) or + (TestValMin > UpperLimit) or (TestValMax > UpperLimit) then + { Overflow } + Break + else if not SmallerOverflow and (TrySmaller <> S_NO) and + ((TestValMin > TrySmallerLimit) or (TestValMax > TrySmallerLimit)) then + SmallerOverflow := True; + + { Contains highest index (so instruction count - 1) } + Inc(InstrMax); + if InstrMax > High(InstrList) then + SetLength(InstrList, InstrMax + LIST_STEP_SIZE); + + InstrList[InstrMax] := taicpu(hp1); + end; + end; + + function TX86AsmOptimizer.OptPass2Imul(var p : tai) : boolean; var hp1 : tai; @@ -6691,6 +7216,41 @@ unit aoptx86; end; + function TX86AsmOptimizer.PostPeepholeOptShr(var p : tai) : boolean; + var + hp1: tai; + begin + { Detect: + shr x, %ax (x > 0) + ... + movzwl %ax,%eax + + Change movzwl %ax,%eax to cwtl (shorter encoding for movswl %ax,%eax) + } + + Result := False; + if MatchOpType(taicpu(p), top_const, top_reg) and + (taicpu(p).oper[1]^.reg = NR_AX) and { This is also enough to determine that opsize = S_W } + (taicpu(p).oper[0]^.val > 0) and + GetNextInstructionUsingReg(p, hp1, NR_EAX) and + MatchInstruction(hp1, A_MOVZX, [S_WL]) and + MatchOperand(taicpu(hp1).oper[0]^, NR_AX) and + MatchOperand(taicpu(hp1).oper[1]^, NR_EAX) then + begin + DebugMsg(SPeepholeOptimization + 'Converted movzwl %ax,%eax to cwtl (via ShrMovz2ShrCwtl)', hp1); + taicpu(hp1).opcode := A_CWDE; + taicpu(hp1).clearop(0); + taicpu(hp1).clearop(1); + taicpu(hp1).ops := 0; + + { A change was made, but not with p, so move forward 1 } + p := tai(p.Next); + Result := True; + end; + + end; + + function TX86AsmOptimizer.PostPeepholeOptCmp(var p : tai) : Boolean; begin Result:=false; @@ -6864,12 +7424,150 @@ unit aoptx86; end; -{$ifdef x86_64} function TX86AsmOptimizer.PostPeepholeOptMovzx(var p : tai) : Boolean; + + function ConstInRange(const Val: TCGInt; const OpSize: TOpSize): Boolean; + begin + case OpSize of + S_B, S_BW, S_BL{$ifdef x86_64}, S_BQ{$endif x86_64}: + Result := (Val <= $FF) and (Val >= -128); + S_W, S_WL{$ifdef x86_64}, S_WQ{$endif x86_64}: + Result := (Val <= $FFFF) and (Val >= -32768); + S_L{$ifdef x86_64}, S_LQ{$endif x86_64}: + Result := (Val <= $FFFFFFFF) and (Val >= -2147483648); + else + Result := True; + end; + end; + var + hp1, hp2 : tai; + SizeChange: Boolean; PreMessage: string; begin Result := False; + + if (taicpu(p).oper[0]^.typ = top_reg) and + SuperRegistersEqual(taicpu(p).oper[0]^.reg, taicpu(p).oper[1]^.reg) and + GetNextInstruction(p, hp1) and (hp1.typ = ait_instruction) then + begin + { Change (using movzbl %al,%eax as an example): + + movzbl %al, %eax movzbl %al, %eax + cmpl x, %eax testl %eax,%eax + + To: + cmpb x, %al testb %al, %al (Move one back to avoid a false dependency) + movzbl %al, %eax movzbl %al, %eax + + Smaller instruction and minimises pipeline stall as the CPU + doesn't have to wait for the register to get zero-extended. [Kit] + + Also allow if the smaller of the two registers is being checked, + as this still removes the false dependency. + } + if + ( + ( + (taicpu(hp1).opcode = A_CMP) and MatchOpType(taicpu(hp1), top_const, top_reg) and + ConstInRange(taicpu(hp1).oper[0]^.val, taicpu(p).opsize) + ) or ( + { If MatchOperand returns True, they must both be registers } + (taicpu(hp1).opcode = A_TEST) and MatchOperand(taicpu(hp1).oper[0]^, taicpu(hp1).oper[1]^) + ) + ) and + (reg2opsize(taicpu(hp1).oper[1]^.reg) <= reg2opsize(taicpu(p).oper[1]^.reg)) then + begin + PreMessage := debug_op2str(taicpu(hp1).opcode) + debug_opsize2str(taicpu(hp1).opsize) + ' ' + debug_operstr(taicpu(hp1).oper[0]^) + ',' + debug_regname(taicpu(hp1).oper[1]^.reg) + ' -> ' + debug_op2str(taicpu(hp1).opcode); + + asml.Remove(hp1); + asml.InsertBefore(hp1, p); + + { Swap instructions in the case of cmp 0,%reg or test %reg,%reg } + if (taicpu(hp1).opcode = A_TEST) or (taicpu(hp1).oper[0]^.val = 0) then + begin + taicpu(hp1).opcode := A_TEST; + taicpu(hp1).loadreg(0, taicpu(p).oper[0]^.reg); + end; + + taicpu(hp1).oper[1]^.reg := taicpu(p).oper[0]^.reg; + + case taicpu(p).opsize of + S_BW, S_BL: + begin + SizeChange := taicpu(hp1).opsize <> S_B; + taicpu(hp1).changeopsize(S_B); + end; + S_WL: + begin + SizeChange := taicpu(hp1).opsize <> S_W; + taicpu(hp1).changeopsize(S_W); + end + else + InternalError(2020112701); + end; + + UpdateUsedRegs(tai(p.Next)); + + { Check if the register is used aferwards - if not, we can + remove the movzx instruction completely } + if not RegUsedAfterInstruction(taicpu(hp1).oper[1]^.reg, p, UsedRegs) then + begin + { Hp1 is a better position than p for debugging purposes } + DebugMsg(SPeepholeOptimization + 'Movzx2Nop 4a', hp1); + RemoveCurrentp(p, hp1); + Result := True; + end; + + if SizeChange then + DebugMsg(SPeepholeOptimization + PreMessage + + debug_opsize2str(taicpu(hp1).opsize) + ' ' + debug_operstr(taicpu(hp1).oper[0]^) + ',' + debug_regname(taicpu(hp1).oper[1]^.reg) + ' (smaller and minimises pipeline stall - MovzxCmp2CmpMovzx)', hp1) + else + DebugMsg(SPeepholeOptimization + 'MovzxCmp2CmpMovzx', hp1); + + Exit; + end; + + { Change (using movzwl %ax,%eax as an example): + + movzwl %ax, %eax + movb %al, (dest) (Register is smaller than read register in movz) + + To: + movb %al, (dest) (Move one back to avoid a false dependency) + movzwl %ax, %eax + } + if (taicpu(hp1).opcode = A_MOV) and + (taicpu(hp1).oper[0]^.typ = top_reg) and + not RegInOp(taicpu(hp1).oper[0]^.reg, taicpu(hp1).oper[1]^) and + SuperRegistersEqual(taicpu(hp1).oper[0]^.reg, taicpu(p).oper[0]^.reg) and + (reg2opsize(taicpu(hp1).oper[0]^.reg) <= reg2opsize(taicpu(p).oper[0]^.reg)) then + begin + DebugMsg(SPeepholeOptimization + 'MovzxMov2MovMovzx', hp1); + + hp2 := tai(hp1.Previous); { Effectively the old position of hp1 } + asml.Remove(hp1); + asml.InsertBefore(hp1, p); + if taicpu(hp1).oper[1]^.typ = top_reg then + AllocRegBetween(taicpu(hp1).oper[1]^.reg, hp1, hp2, UsedRegs); + + { Check if the register is used aferwards - if not, we can + remove the movzx instruction completely } + + if not RegUsedAfterInstruction(taicpu(hp1).oper[0]^.reg, p, UsedRegs) then + begin + { Hp1 is a better position than p for debugging purposes } + DebugMsg(SPeepholeOptimization + 'Movzx2Nop 4b', hp1); + RemoveCurrentp(p, hp1); + Result := True; + end; + + Exit; + end; + + end; + +{$ifdef x86_64} { Code size reduction by J. Gareth "Kit" Moreton } { Convert MOVZBQ and MOVZWQ to MOVZBL and MOVZWL respectively if it removes the REX prefix } if (taicpu(p).opsize in [S_BQ, S_WQ]) and @@ -6889,9 +7587,11 @@ unit aoptx86; DebugMsg(SPeepholeOptimization + PreMessage + debug_opsize2str(taicpu(p).opsize) + ' ' + debug_operstr(taicpu(p).oper[0]^) + ',' + debug_regname(taicpu(p).oper[1]^.reg) + ' (removes REX prefix)', p); end; +{$endif} end; +{$ifdef x86_64} function TX86AsmOptimizer.PostPeepholeOptXor(var p : tai) : Boolean; var PreMessage, RegName: string; diff --git a/compiler/x86_64/aoptcpu.pas b/compiler/x86_64/aoptcpu.pas index 0ed4c9701b..5ac6583fd5 100644 --- a/compiler/x86_64/aoptcpu.pas +++ b/compiler/x86_64/aoptcpu.pas @@ -163,6 +163,8 @@ uses case taicpu(p).opcode of A_MOV: Result:=OptPass2MOV(p); + A_MOVZX: + Result:=OptPass2Movx(p); A_IMUL: Result:=OptPass2Imul(p); A_JMP: @@ -213,6 +215,8 @@ uses Result:=PostPeepholeOptLea(p); A_PUSH: Result:=PostPeepholeOptPush(p); + A_SHR: + Result:=PostPeepholeOptShr(p); else ; end; From 87f2c282d1615706b9e3f3f68658550bc6984f2e Mon Sep 17 00:00:00 2001 From: michael Date: Tue, 5 Jan 2021 17:00:32 +0000 Subject: [PATCH 4/6] * Patch from Andrey Sobol to reduce indentation git-svn-id: trunk@48087 - --- utils/fpdoc/dw_chm.pp | 425 +++++++++++++++++++++--------------------- 1 file changed, 215 insertions(+), 210 deletions(-) diff --git a/utils/fpdoc/dw_chm.pp b/utils/fpdoc/dw_chm.pp index e37076e24b..3e2e99f045 100644 --- a/utils/fpdoc/dw_chm.pp +++ b/utils/fpdoc/dw_chm.pp @@ -322,58 +322,60 @@ var begin DoLog('Generating Table of contents...'); - if Assigned(Package) then + if not Assigned(Package) then begin - Toc := TChmSiteMap.Create(stTOC); - Stream := TMemoryStream.Create; - ObjByUnitItem := TOC.Items.NewItem; - ObjByUnitItem.Text := 'Classes and Objects, by Unit'; - AlphaObjItem := TOC.Items.NewItem; - AlphaObjItem.Text := 'Alphabetical Classes and Objects List'; - RoutinesByUnitItem := TOC.Items.NewItem; - RoutinesByUnitItem.Text := 'Routines, by Unit'; - AlphaRoutinesItem := TOC.Items.NewItem; - AlphaRoutinesItem.Text := 'Alphabetical Routines List'; + DoLog('Package is not assigned...'); + Exit; + end; + Toc := TChmSiteMap.Create(stTOC); + Stream := TMemoryStream.Create; + ObjByUnitItem := TOC.Items.NewItem; + ObjByUnitItem.Text := 'Classes and Objects, by Unit'; + AlphaObjItem := TOC.Items.NewItem; + AlphaObjItem.Text := 'Alphabetical Classes and Objects List'; + RoutinesByUnitItem := TOC.Items.NewItem; + RoutinesByUnitItem.Text := 'Routines, by Unit'; + AlphaRoutinesItem := TOC.Items.NewItem; + AlphaRoutinesItem.Text := 'Alphabetical Routines List'; - // objects and classes - for i := 0 to Package.Modules.Count - 1 do + // objects and classes + for i := 0 to Package.Modules.Count - 1 do + begin + AModule := TPasModule(Package.Modules[i]); + If not assigned(AModule.InterfaceSection) Then + Continue; + ObjUnitItem := ObjByUnitItem.Children.NewItem; + ObjUnitItem.Text := AModule.Name; + RoutinesUnitItem := RoutinesByUnitItem.Children.NewItem; + RoutinesUnitItem.Text := AModule.Name; + for j := 0 to AModule.InterfaceSection.Classes.Count-1 do begin - AModule := TPasModule(Package.Modules[i]); - If not assigned(AModule.InterfaceSection) Then - Continue; - ObjUnitItem := ObjByUnitItem.Children.NewItem; - ObjUnitItem.Text := AModule.Name; - RoutinesUnitItem := RoutinesByUnitItem.Children.NewItem; - RoutinesUnitItem.Text := AModule.Name; - for j := 0 to AModule.InterfaceSection.Classes.Count-1 do - begin - Element := TPasClassType(AModule.InterfaceSection.Classes[j]); - // by unit - TmpItem := ObjUnitItem.Children.NewItem; - TmpItem.Text := Element.Name; - TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(Element, 0))); - - //alpha - TmpItem := GetAlphaItem(AlphaObjItem.Children, UpperCase(Copy(Element.Name, 1, 2))).Children.NewItem; - TmpItem.Text := Element.Name; - TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(Element, 0))); - - end; - - // non object procedures and functions - for j := 0 to AModule.InterfaceSection.Functions.Count-1 do - begin - Element := TPasFunctionType(AModule.InterfaceSection.Functions[j]); - // by unit - TmpItem := RoutinesUnitItem.Children.NewItem; - TmpItem.Text := Element.Name; - TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(Element, 0))); - - // alpha - TmpItem := GetAlphaItem(AlphaRoutinesItem.Children, UpperCase(Element.Name[1])).Children.NewItem; - TmpItem.Text := Element.Name; - TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(Element, 0))); - end; + Element := TPasClassType(AModule.InterfaceSection.Classes[j]); + // by unit + TmpItem := ObjUnitItem.Children.NewItem; + TmpItem.Text := Element.Name; + TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(Element, 0))); + + //alpha + TmpItem := GetAlphaItem(AlphaObjItem.Children, UpperCase(Copy(Element.Name, 1, 2))).Children.NewItem; + TmpItem.Text := Element.Name; + TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(Element, 0))); + + end; + + // non object procedures and functions + for j := 0 to AModule.InterfaceSection.Functions.Count-1 do + begin + Element := TPasFunctionType(AModule.InterfaceSection.Functions[j]); + // by unit + TmpItem := RoutinesUnitItem.Children.NewItem; + TmpItem.Text := Element.Name; + TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(Element, 0))); + + // alpha + TmpItem := GetAlphaItem(AlphaRoutinesItem.Children, UpperCase(Element.Name[1])).Children.NewItem; + TmpItem.Text := Element.Name; + TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(Element, 0))); end; end; // cleanup @@ -406,7 +408,7 @@ begin end; if not fnobintoc then - fchm.AppendBinaryTOCFromSiteMap(Toc); + fchm.AppendBinaryTOCFromSiteMap(Toc); TOC.SaveToStream(Stream); TOC.Free; @@ -461,164 +463,166 @@ var begin DoLog('Generating Index...'); - if Assigned(Package) then + if not Assigned(Package) then begin - Index := TChmSiteMap.Create(stIndex); - Stream := TMemoryStream.Create; - for i := 0 to Package.Modules.Count - 1 do - begin - AModule := TPasModule(Package.Modules[i]); - if not assigned(AModule.InterfaceSection) then - continue; - ParentItem := Index.Items.NewItem; - ParentItem.Text := AModule.Name; - ParentItem.addLocal(FixHTMLpath(Allocator.GetFilename(AModule, 0))); - - // classes - for j := 0 to AModule.InterfaceSection.Classes.Count-1 do - begin - ParentElement := TPasClassType(AModule.InterfaceSection.Classes[j]); - ParentItem := Index.Items.NewItem; - ParentItem.Text := ParentELement.Name; - ParentItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0))); - for k := 0 to TPasClassType(ParentElement).Members.Count-1 do - begin - TmpElement := TPasElement(TPasClassType(ParentElement).Members.Items[k]); - if Engine.HidePrivate and(TmpElement.Visibility = visPrivate) then - continue; - if Engine.HideProtected and(TmpElement.Visibility = visProtected) then - continue; - Urls:=FixHTMLpath(Allocator.GetFilename(TmpElement, 0)); - RedirectUrl:=''; - if TmpElement is TPasEnumValue then - RedirectUrl := UTF8Encode(ResolveLinkIDAbs(tmpElement.Parent.PathName)) - else - RedirectUrl := UTF8Encode(ResolveLinkIDAbs(tmpElement.PathName)); - - if(trim(RedirectUrl)<>'') and (RedirectUrl<>urls) then - begin - //writeln('Hint: Index Resolved:',urls,' to ',RedirectUrl); - urls:=RedirectUrl; - end; - - TmpItem := ParentItem.Children.NewItem; - case ElementType(TmpElement) of - cmtProcedure : TmpItem.Text := TmpElement.Name + ' procedure'; - cmtFunction : TmpItem.Text := TmpElement.Name + ' function'; - cmtConstructor : TmpItem.Text := TmpElement.Name + ' constructor'; - cmtDestructor : TmpItem.Text := TmpElement.Name + ' destructor'; - cmtProperty : TmpItem.Text := TmpElement.Name + ' property'; - cmtVariable : TmpItem.Text := TmpElement.Name + ' variable'; - cmtInterface : TmpItem.Text := TmpElement.Name + ' interface'; - cmtOperator : TmpItem.Text := TmpElement.Name + ' operator'; - cmtConstant : TmpItem.Text := TmpElement.Name + ' const'; - cmtUnknown : TmpItem.Text := TmpElement.Name; - end; - TmpItem.addLocal(Urls); - { - ParentElement = Class - TmpElement = Member - } - MemberItem := nil; - MemberItem := GetAlphaItem(Index.Items, TmpElement.Name); - // ahh! if MemberItem.Local is empty MemberType is not shown! - MemberItem.addLocal(Urls); - - TmpItem := MemberItem.Children.NewItem; - TmpItem.Text := ParentElement.Name; - TmpItem.AddLocal(Urls); - end; - end; - // routines - for j := 0 to AModule.InterfaceSection.Functions.Count-1 do - begin - // routine name - ParentElement := TPasElement(AModule.InterfaceSection.Functions[j]); - case ElementType(ParentElement) of - cmtProcedure : SName:= ' procedure'; - cmtFunction : SName:= ' function'; - cmtOperator : SName:= ' operator'; - //cmtConstant : SName:= ' const'; - else SName:= ' unknown' - end; - SName:= ParentElement.Name + ' ' + SName; - MultiAlphaItem(Index.Items, SName, ParentElement, AModule.Name); - end; - // consts - for j := 0 to AModule.InterfaceSection.Consts.Count-1 do - begin - ParentElement := TPasElement(AModule.InterfaceSection.Consts[j]); - SName:= ParentElement.Name + ' const'; - MultiAlphaItem(Index.Items, SName, ParentElement, AModule.Name); - end; - // types - for j := 0 to AModule.InterfaceSection.Types.Count-1 do - begin - ParentElement := TPasType(AModule.InterfaceSection.Types[j]); - TmpItem := Index.Items.NewItem; - TmpItem.Text := ParentElement.Name; - TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0))); - // enums - if ParentELement is TPasEnumType then - begin - ParentItem := TmpItem; - for k := 0 to TPasEnumType(ParentElement).Values.Count-1 do - begin - TmpElement := TPasType(TPasEnumType(ParentElement).Values.Items[k]); - // subitem - TmpItem := ParentItem.Children.NewItem; - TmpItem.Text := TmpElement.Name; - TmpItem.addLocal(ParentItem.Local); - // root level - TmpItem := Index.Items.NewItem; - TmpItem.Text := TmpElement.Name; - TmpItem.addLocal(ParentItem.Local); - end; - end; - end; - // variables - for j := 0 to AModule.InterfaceSection.Variables.Count-1 do - begin - ParentElement := TPasElement(AModule.InterfaceSection.Variables[j]); - SName:= ParentElement.Name + ' variable'; - MultiAlphaItem(Index.Items, SName, ParentElement, AModule.Name); - end; - // declarations - { - for j := 0 to AModule.InterfaceSection.Declarations.Count-1 do - begin - ParentElement := TPasElement(AModule.InterfaceSection.Declarations[j]); - TmpItem := Index.Items.NewItem; - TmpItem.Text := ParentElement.Name; - TmpItem.Local := FixHTMLpath(Allocator.GetFilename(ParentElement, 0)); - end; - // resource strings - for j := 0 to AModule.InterfaceSection.ResStrings.Count-1 do - begin - ParentElement := TPasElement(AModule.InterfaceSection.ResStrings[j]); - TmpItem := Index.Items.NewItem; - TmpItem.Text := ParentElement.Name; - TmpItem.Local := FixHTMLpath(Allocator.GetFilename(ParentElement, 0)); - end; - } - end; - - // Sort - Index.Items.Sort(TListSortCompare(@TOCSort)); - for i := 0 to Index.Items.Count-1 do - begin - Index.Items.Item[i].Children.Sort(TListSortCompare(@TOCSort)); - end; - - // save - Index.SaveToStream(Stream); - if not fnobinindex then - fchm.AppendBinaryindexFromSitemap(index,false); - Index.Free; - Stream.Position :=0 ; - FChm.AppendIndex(Stream); - Stream.Free; + DoLog('Package is not assigned...'); + Exit; end; + Index := TChmSiteMap.Create(stIndex); + Stream := TMemoryStream.Create; + for i := 0 to Package.Modules.Count - 1 do + //if false then + begin + AModule := TPasModule(Package.Modules[i]); + if not assigned(AModule.InterfaceSection) then + continue; + ParentItem := Index.Items.NewItem; + ParentItem.Text := AModule.Name; + ParentItem.addLocal(FixHTMLpath(Allocator.GetFilename(AModule, 0))); + + // classes + for j := 0 to AModule.InterfaceSection.Classes.Count-1 do + begin + ParentElement := TPasClassType(AModule.InterfaceSection.Classes[j]); + ParentItem := Index.Items.NewItem; + ParentItem.Text := ParentELement.Name; + ParentItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0))); + for k := 0 to TPasClassType(ParentElement).Members.Count-1 do + begin + TmpElement := TPasElement(TPasClassType(ParentElement).Members.Items[k]); + if Engine.HidePrivate and(TmpElement.Visibility = visPrivate) then + continue; + if Engine.HideProtected and(TmpElement.Visibility = visProtected) then + continue; + Urls:=FixHTMLpath(Allocator.GetFilename(TmpElement, 0)); + RedirectUrl:=''; + if TmpElement is TPasEnumValue then + RedirectUrl := UTF8Encode(ResolveLinkIDAbs(tmpElement.Parent.PathName)) + else + RedirectUrl := UTF8Encode(ResolveLinkIDAbs(tmpElement.PathName)); + + if(trim(RedirectUrl)<>'') and (RedirectUrl<>urls) then + begin + //writeln('Hint: Index Resolved:',urls,' to ',RedirectUrl); + urls:=RedirectUrl; + end; + + TmpItem := ParentItem.Children.NewItem; + case ElementType(TmpElement) of + cmtProcedure : TmpItem.Text := TmpElement.Name + ' procedure'; + cmtFunction : TmpItem.Text := TmpElement.Name + ' function'; + cmtConstructor : TmpItem.Text := TmpElement.Name + ' constructor'; + cmtDestructor : TmpItem.Text := TmpElement.Name + ' destructor'; + cmtProperty : TmpItem.Text := TmpElement.Name + ' property'; + cmtVariable : TmpItem.Text := TmpElement.Name + ' variable'; + cmtInterface : TmpItem.Text := TmpElement.Name + ' interface'; + cmtOperator : TmpItem.Text := TmpElement.Name + ' operator'; + cmtConstant : TmpItem.Text := TmpElement.Name + ' const'; + cmtUnknown : TmpItem.Text := TmpElement.Name; + end; + TmpItem.addLocal(Urls); + { + ParentElement = Class + TmpElement = Member + } + MemberItem := nil; + MemberItem := GetAlphaItem(Index.Items, TmpElement.Name); + // ahh! if MemberItem.Local is empty MemberType is not shown! + MemberItem.addLocal(Urls); + + TmpItem := MemberItem.Children.NewItem; + TmpItem.Text := ParentElement.Name; + TmpItem.AddLocal(Urls); + end; + end; + // routines + for j := 0 to AModule.InterfaceSection.Functions.Count-1 do + begin + // routine name + ParentElement := TPasElement(AModule.InterfaceSection.Functions[j]); + case ElementType(ParentElement) of + cmtProcedure : SName:= ' procedure'; + cmtFunction : SName:= ' function'; + cmtOperator : SName:= ' operator'; + //cmtConstant : SName:= ' const'; + else SName:= ' unknown' + end; + SName:= ParentElement.Name + ' ' + SName; + MultiAlphaItem(Index.Items, SName, ParentElement, AModule.Name); + end; + // consts + for j := 0 to AModule.InterfaceSection.Consts.Count-1 do + begin + ParentElement := TPasElement(AModule.InterfaceSection.Consts[j]); + SName:= ParentElement.Name + ' const'; + MultiAlphaItem(Index.Items, SName, ParentElement, AModule.Name); + end; + // types + for j := 0 to AModule.InterfaceSection.Types.Count-1 do + begin + ParentElement := TPasType(AModule.InterfaceSection.Types[j]); + TmpItem := Index.Items.NewItem; + TmpItem.Text := ParentElement.Name; + TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0))); + // enums + if ParentELement is TPasEnumType then + begin + ParentItem := TmpItem; + for k := 0 to TPasEnumType(ParentElement).Values.Count-1 do + begin + TmpElement := TPasType(TPasEnumType(ParentElement).Values.Items[k]); + // subitem + TmpItem := ParentItem.Children.NewItem; + TmpItem.Text := TmpElement.Name; + TmpItem.addLocal(ParentItem.Local); + // root level + TmpItem := Index.Items.NewItem; + TmpItem.Text := TmpElement.Name; + TmpItem.addLocal(ParentItem.Local); + end; + end; + end; + // variables + for j := 0 to AModule.InterfaceSection.Variables.Count-1 do + begin + ParentElement := TPasElement(AModule.InterfaceSection.Variables[j]); + SName:= ParentElement.Name + ' variable'; + MultiAlphaItem(Index.Items, SName, ParentElement, AModule.Name); + end; + // declarations + { + for j := 0 to AModule.InterfaceSection.Declarations.Count-1 do + begin + ParentElement := TPasElement(AModule.InterfaceSection.Declarations[j]); + TmpItem := Index.Items.NewItem; + TmpItem.Text := ParentElement.Name; + TmpItem.Local := FixHTMLpath(Allocator.GetFilename(ParentElement, 0)); + end; + // resource strings + for j := 0 to AModule.InterfaceSection.ResStrings.Count-1 do + begin + ParentElement := TPasElement(AModule.InterfaceSection.ResStrings[j]); + TmpItem := Index.Items.NewItem; + TmpItem.Text := ParentElement.Name; + TmpItem.Local := FixHTMLpath(Allocator.GetFilename(ParentElement, 0)); + end; + } + end; + + // Sort + Index.Items.Sort(TListSortCompare(@TOCSort)); + for i := 0 to Index.Items.Count-1 do + begin + Index.Items.Item[i].Children.Sort(TListSortCompare(@TOCSort)); + end; + // save + Index.SaveToStream(Stream); + if not fnobinindex then + fchm.AppendBinaryindexFromSitemap(index,false); + Index.Free; + Stream.Position :=0 ; + FChm.AppendIndex(Stream); + Stream.Free; DoLog('Generating Index Done'); end; @@ -646,8 +650,9 @@ begin FChm.TempRawStream := FTempUncompressed; FChm.OnGetFileData := @RetrieveOtherFiles; FChm.OnLastFile := @LastFileAdded; - fchm.hasbinarytoc:=not fnobintoc;; - fchm.hasbinaryindex:=not fnobinindex; + FChm.hasbinarytoc:=not fnobintoc; + FChm.hasbinaryindex:=not fnobinindex; + //FChm.Cores:=1; ProcessOptions; FileStream := TMemoryStream.Create; @@ -663,7 +668,7 @@ begin WriteHTMLFile(PageDoc, FileStream); FChm.AddStreamToArchive(FileName, FilePath, FileStream, True); except - on E: Exception do + on E: Exception do DoLog(Format(SErrCouldNotCreateFile, [FileName, e.Message])); end; finally @@ -698,7 +703,7 @@ begin FChm.Execute; FChm.Free; DoLog('Collecting done'); - // we don't need to free FTempUncompressed + // we don't need to free FTempUncompressed it is freed into TFpDocChmWriter // FTempUncompressed.Free; FOutChm.Free; DeleteFile(FTempUncompressedName); From 57d9884d964cc8e1208814fc3b0f381c3140e642 Mon Sep 17 00:00:00 2001 From: svenbarth Date: Tue, 5 Jan 2021 20:58:46 +0000 Subject: [PATCH 5/6] * fix for Mantis #38310: ignore procsyms that have no procdefs for checking overloads, or more precisely to stop checking for overloads; these are generic dummy symbols + added (simplified) tests git-svn-id: trunk@48088 - --- .gitattributes | 3 +++ compiler/htypechk.pas | 9 ++++++--- tests/webtbs/tw38310a.pp | 12 ++++++++++++ tests/webtbs/tw38310b.pp | 12 ++++++++++++ tests/webtbs/tw38310c.pp | 12 ++++++++++++ 5 files changed, 45 insertions(+), 3 deletions(-) create mode 100644 tests/webtbs/tw38310a.pp create mode 100644 tests/webtbs/tw38310b.pp create mode 100644 tests/webtbs/tw38310c.pp diff --git a/.gitattributes b/.gitattributes index 1e20795141..cd485efcde 100644 --- a/.gitattributes +++ b/.gitattributes @@ -18632,6 +18632,9 @@ tests/webtbs/tw3827.pp svneol=native#text/plain tests/webtbs/tw3829.pp svneol=native#text/plain tests/webtbs/tw38295.pp svneol=native#text/pascal tests/webtbs/tw38299.pp svneol=native#text/pascal +tests/webtbs/tw38310a.pp svneol=native#text/pascal +tests/webtbs/tw38310b.pp svneol=native#text/pascal +tests/webtbs/tw38310c.pp svneol=native#text/pascal tests/webtbs/tw3833.pp svneol=native#text/plain tests/webtbs/tw3840.pp svneol=native#text/plain tests/webtbs/tw3841.pp svneol=native#text/plain diff --git a/compiler/htypechk.pas b/compiler/htypechk.pas index 0ab2cb3595..7e805b73e9 100644 --- a/compiler/htypechk.pas +++ b/compiler/htypechk.pas @@ -2299,7 +2299,8 @@ implementation srsym:=tsym(helperdef.symtable.FindWithHash(hashedid)); if assigned(srsym) and { Delphi allows hiding a property by a procedure with the same name } - (srsym.typ=procsym) then + (srsym.typ=procsym) and + (tprocsym(srsym).procdeflist.count>0) then begin hasoverload:=processprocsym(tprocsym(srsym),foundanything); { when there is no explicit overload we stop searching } @@ -2388,7 +2389,8 @@ implementation srsym:=tprocsym(tabstractrecorddef(tobjectdef(structdef).extendeddef).symtable.FindWithHash(hashedid)); if assigned(srsym) and { Delphi allows hiding a property by a procedure with the same name } - (srsym.typ=procsym) then + (srsym.typ=procsym) and + (tprocsym(srsym).procdeflist.count>0) then begin hasoverload:=processprocsym(tprocsym(srsym),foundanything); { when there is no explicit overload we stop searching } @@ -2463,7 +2465,8 @@ implementation begin srsym:=tsym(srsymtable.FindWithHash(hashedid)); if assigned(srsym) and - (srsym.typ=procsym) then + (srsym.typ=procsym) and + (tprocsym(srsym).procdeflist.count>0) then begin { add all definitions } hasoverload:=false; diff --git a/tests/webtbs/tw38310a.pp b/tests/webtbs/tw38310a.pp new file mode 100644 index 0000000000..80a774e78e --- /dev/null +++ b/tests/webtbs/tw38310a.pp @@ -0,0 +1,12 @@ +{ %NORUN } + +program tw38310a; + +{$mode objfpc}{$H+} + +uses + SysUtils, StrUtils, Math; + +begin + IfThen(true, 'A', IfThen(true, 'B', 'C')); +end. diff --git a/tests/webtbs/tw38310b.pp b/tests/webtbs/tw38310b.pp new file mode 100644 index 0000000000..248877aba9 --- /dev/null +++ b/tests/webtbs/tw38310b.pp @@ -0,0 +1,12 @@ +{ %NORUN } + +program tw38310b; + +{$mode objfpc}{$H+} + +uses + StrUtils, SysUtils, Math; + +begin + IfThen(true, 'A', IfThen(true, 'B', 'C')); +end. diff --git a/tests/webtbs/tw38310c.pp b/tests/webtbs/tw38310c.pp new file mode 100644 index 0000000000..3eabeb96b0 --- /dev/null +++ b/tests/webtbs/tw38310c.pp @@ -0,0 +1,12 @@ +{ %NORUN } + +program tw38310c; + +{$mode objfpc}{$H+} + +uses + StrUtils, Math, SysUtils; + +begin + IfThen(true, 'A', IfThen(true, 'B', 'C')); +end. From aec18c2426a503c0c85e057bbc2f029d649fe3bf Mon Sep 17 00:00:00 2001 From: florian Date: Tue, 5 Jan 2021 22:39:16 +0000 Subject: [PATCH 6/6] * weight currency->float conversions the same regardless if the currency type is handled by the integer unit or the x87 fpu, resolves #38309 git-svn-id: trunk@48089 - --- .gitattributes | 1 + compiler/defcmp.pas | 6 ++--- tests/webtbs/tw38309.pp | 56 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 60 insertions(+), 3 deletions(-) create mode 100644 tests/webtbs/tw38309.pp diff --git a/.gitattributes b/.gitattributes index cd485efcde..b6ed4a29e7 100644 --- a/.gitattributes +++ b/.gitattributes @@ -18632,6 +18632,7 @@ tests/webtbs/tw3827.pp svneol=native#text/plain tests/webtbs/tw3829.pp svneol=native#text/plain tests/webtbs/tw38295.pp svneol=native#text/pascal tests/webtbs/tw38299.pp svneol=native#text/pascal +tests/webtbs/tw38309.pp svneol=native#text/pascal tests/webtbs/tw38310a.pp svneol=native#text/pascal tests/webtbs/tw38310b.pp svneol=native#text/pascal tests/webtbs/tw38310c.pp svneol=native#text/pascal diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas index 1d18a1649b..867b09f141 100644 --- a/compiler/defcmp.pas +++ b/compiler/defcmp.pas @@ -843,11 +843,11 @@ implementation { and conversion to float is favoured) } doconv:=tc_int_2_real; if is_extended(def_to) then - eq:=te_convert_l2 + eq:=te_convert_l1 else if is_double(def_to) then - eq:=te_convert_l3 + eq:=te_convert_l2 else if is_single(def_to) then - eq:=te_convert_l4 + eq:=te_convert_l3 else eq:=te_convert_l2; end; diff --git a/tests/webtbs/tw38309.pp b/tests/webtbs/tw38309.pp new file mode 100644 index 0000000000..a33ef45053 --- /dev/null +++ b/tests/webtbs/tw38309.pp @@ -0,0 +1,56 @@ +program c; + +{$mode objfpc} + +uses + Math; + +type + generic TBase = class + private const + AConst = 1; + private + GenVarA: T; + GenVarB: T; + function Foo: Boolean; + end; + + function TBase.Foo: Boolean; + begin + //Fails with trunk win-64 if TCur type is defined (e.g. not commented out) (*) + Result := SameValue(AConst, GenVarB); + + //Fails with trunk win-64, EVEN if TCur definition is commented out + //Fails with 3.2.0 win-32, EVEN if TCur definition is commented out + //Fails with 3.2.0 win-64, EVEN if TCur definition is commented out, if it is defined it gives the errormesage twice for this line + Result := SameValue(GenVarA, GenVarB); + + //Fails with trunk win-64 if TCur type is defined (e.g. not commented out) + Result := SameValue(GenVarA, AConst); + end; + +type + TCur = specialize TBase; + +const + CurConst = 1; +var + CurVarA: Currency = 1; + CurVarB: Currency = 2; + +begin + //Fails with trunk win-64 + SameValue(CurConst, CurVarA); + + //Fails with 3.2.0 win-64 + SameValue(Currency(CurConst), CurVarA); + + //Fails with 3.2.0 win-64 + SameValue(CurVarA, CurVarB); + + //Fails with trunk win-64 + SameValue(CurVarA, CurConst); + + //Fails with 3.2.0 win-64 + SameValue(CurVarA, Currency(CurConst)); +end.