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
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| 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. |
The Wiert Corner - irregular stream of stuff 
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…