Delphi still doesn’t raise overflow exception on Int64 multiplication…
Posted by jpluimers on 2018/06/28
Thanks to Stefan Glienke for pointing me at the below patch for [WayBack] Why doesn’t raise overflow exception on multiplication example or how to detect in this case?{$RANGECHECKS ON} {$OVERFLOWCHECKS ON}varvalue: Int64;… – Rafael Dipold – Google+.
It’s basically an issue in __llmulo that has been documented but not solved since “forever”:
some people “some while ago” reported this and even posted a solution: [WayBack]Ā http://qc.embarcadero.com/wc/qcmain.aspx?d=34049
And there it is again: [WayBack]Ā http://qc.embarcadero.com/wc/qcmain.aspx?d=119146
And most recently:Ā https://quality.embarcadero.com/browse/RSP-16617
FWIW here is a runtime patch that corrects this (using the version posted in QC#119146):Ā https://pastebin.com/jzLgYeqm
The bug tracking of the Delphi team is so bad, that some of the reports actually mark this issue “As Designed” like in [WayBack]Ā http://qc.embarcadero.com/wc/qcmain.aspx?d=118287
The below patch requires rights to call [WayBack]Ā WriteProcessMemoryĀ as documented inĀ [WayBack]Ā How to Read and Write Other Process Memory.
–jeroen
Patch at [WayBack] https://pastebin.com/jzLgYeqm
| unit PatchInt64Multiplication; | |
| interface | |
| implementation | |
| {$IF Defined(MSWINDOWS) and not Defined(CPUX64)} | |
| uses | |
| SysUtils, | |
| Windows; | |
| function GetActualAddr(Proc: Pointer): Pointer; | |
| type | |
| PAbsoluteIndirectJmp = ^TAbsoluteIndirectJmp; | |
| TAbsoluteIndirectJmp = packed record | |
| OpCode: Word; | |
| Addr: PPointer; | |
| end; | |
| begin | |
| Result := Proc; | |
| if (Proc <> nil) and (PAbsoluteIndirectJmp(Proc).OpCode = $25FF) then | |
| Result := PAbsoluteIndirectJmp(Proc).Addr^; | |
| end; | |
| procedure RedirectFunction(OrgProc, NewProc: Pointer); | |
| type | |
| TJmpBuffer = packed record | |
| Jmp: Byte; | |
| Offset: Integer; | |
| end; | |
| var | |
| n: UINT_PTR; | |
| JmpBuffer: TJmpBuffer; | |
| begin | |
| JmpBuffer.Jmp := $E9; | |
| JmpBuffer.Offset := PByte(NewProc) - (PByte(OrgProc) + 5); | |
| if not WriteProcessMemory(GetCurrentProcess, OrgProc, @JmpBuffer, SizeOf(JmpBuffer), n) then | |
| RaiseLastOSError; | |
| end; | |
| procedure __llmulo_patch; | |
| asm | |
| test edx, edx {Param1-Hi = 0?} | |
| jne @@Large {No, More than one multiply may be needed} | |
| cmp edx, [esp+8] {Param2-Hi = 0?} | |
| jne @@Large {No, More than one multiply may be needed} | |
| mul dword ptr [esp+4] {Only one multiply needed, Set Result} | |
| and eax, eax {Clear Overflow Flag} | |
| ret 8 | |
| @@Large: | |
| sub esp, 28 {allocate local storage} | |
| mov [esp], ebx {save used registers} | |
| mov [esp+4], esi | |
| mov [esp+8], edi | |
| mov [esp+12], ebp | |
| mov ebx, [esp+32] {Param2-Lo} | |
| mov ecx, [esp+36] {Param2-Hi} | |
| mov esi, edx | |
| mov edi, ecx | |
| sar esi, 31 | |
| sar edi, 31 | |
| xor eax, esi | |
| xor edx, esi | |
| sub eax, esi | |
| sbb edx, esi {edx:eax (a1:a0) = abs(Param1)} | |
| xor ebx, edi | |
| xor ecx, edi | |
| sub ebx, edi | |
| sbb ecx, edi {ecx:ebx (b1:b0) = abs(Param2)} | |
| xor esi, edi {Sign Flag, 0 if Params have same sign else -1} | |
| mov [esp+16], eax {a0} | |
| mov [esp+20], edx {a1} | |
| mov [esp+24], ecx {b1} | |
| mul ebx {edx:eax (c1:c0) = a0*b0} | |
| xchg ebx, edx {ebx = c1, edx = b0} | |
| mov edi, eax {abs(Result-Lo) = c0} | |
| xor ecx, ecx {Upper 32 bits of 128 bit result} | |
| xor ebp, ebp {Second 32 bits of 128 bit result} | |
| mov eax, [esp+20] {a1} | |
| mul edx {edx:eax (d1:d0) = a1*b0} | |
| add ebx, eax {c1 + d0} | |
| adc ebp, edx {d1 + carry} | |
| adc ecx, 0 {Possible carry into Upper 32 bits} | |
| mov eax, [esp+16] {a0} | |
| mov edx, [esp+24] {b1} | |
| mul edx {edx:eax (e1:e0) = a0*b1} | |
| add ebx, eax {abs(Result-Hi) = c1 + d0 + e0} | |
| adc ebp, edx {d1 + e1 + carry} | |
| adc ecx, 0 {Possible carry into Upper 32 bits} | |
| mov eax, [esp+20] {a1} | |
| mov edx, [esp+24] {b1} | |
| mul edx {edx:eax (f1:f0) = a1*b1} | |
| add ebp, eax {d1 + e1 + f0 + carry} | |
| adc ecx, edx {f1 + carry} | |
| or ecx, ebp {Overflow if ecx <> 0 or ebp <> 0} | |
| jnz @@Overflow | |
| mov edx, ebx {Set abs(Result-Hi)} | |
| mov eax, edi {Set abs(Result-Lo)} | |
| cmp edx, $80000000 | |
| jae @@CheckRange {Possible Overflow if edx>=$80000000} | |
| @@SetSign: | |
| xor eax, esi {Correct Sign of Result} | |
| xor edx, esi | |
| sub eax, esi | |
| sbb edx, esi | |
| mov ebx, [esp] {restore used registers} | |
| mov esi, [esp+4] | |
| mov edi, [esp+8] | |
| mov ebp, [esp+12] | |
| add esp, 28 {Clears Overflow flag} | |
| ret 8 | |
| @@CheckRange: | |
| jne @@Overflow {Overflow if edx>$80000000} | |
| test esi, esi {edx=$80000000, Is Sign Flag=0?} | |
| jnz @@SetSign {No, Result is Ok (-MaxInt64)} | |
| @@Overflow: | |
| mov ebx, [esp] {restore used registers} | |
| mov esi, [esp+4] | |
| mov edi, [esp+8] | |
| mov ebp, [esp+12] | |
| add esp, 28 | |
| mov ecx, $80000000 | |
| dec ecx {Set Overflow Flag} | |
| ret 8 | |
| end; | |
| function GetSystem__llmulo: Pointer; | |
| asm | |
| mov eax,offset System.@_llmulo | |
| end; | |
| procedure PatchIt; | |
| begin | |
| RedirectFunction(GetActualAddr(GetSystem__llmulo), @__llmulo_patch); | |
| end; | |
| initialization | |
| PatchIt; | |
| {$IFEND} | |
| end. |
rvelthuis said
As others said, it was fixed. I reported https://quality.embarcadero.com/browse/RSP-16617 and I checked it regularly. It is fixed.
Marco Cantu said
As https://quality.embarcadero.com/browse/RSP-16617 indicates it was fixed in 10.2 Tokyo
HeartWare said
It sems to have been fixed in 10.2.3
VAR
I : Int64;
BEGIN
{$Q+}
I:=Int64.MaxValue; I:=I*2;
END;
produces an integer overflow exception…