915 lines
32 KiB
ObjectPascal
915 lines
32 KiB
ObjectPascal
{**************************************************************************************************}
|
|
{ }
|
|
{ Project JEDI Code Library (JCL) }
|
|
{ }
|
|
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
|
|
{ you may not use this file except in compliance with the License. You may obtain a copy of the }
|
|
{ License at http://www.mozilla.org/MPL/ }
|
|
{ }
|
|
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF }
|
|
{ ANY KIND, either express or implied. See the License for the specific language governing rights }
|
|
{ and limitations under the License. }
|
|
{ }
|
|
{ The Original Code is: JvSIMDUtils.pas, released on 2004-10-11. }
|
|
{ }
|
|
{ The Initial Developer of the Original Code is Florent Ouchet }
|
|
{ [ouchet dott florent att laposte dott net] }
|
|
{ Portions created by Florent Ouchet are Copyright (C) 2004 Florent Ouchet. }
|
|
{ All Rights Reserved. }
|
|
{ }
|
|
{ You may retrieve the latest version of this file at the Project JEDI's JCL home page, }
|
|
{ located at http://jcl.sourceforge.net }
|
|
{ }
|
|
{**************************************************************************************************}
|
|
|
|
// $Id: JclSIMDUtils.pas,v 1.6 2005/12/16 23:46:25 outchy Exp $
|
|
|
|
unit JclSIMDUtils;
|
|
|
|
{$I jcl.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
Windows,
|
|
ToolsAPI,
|
|
JclSysInfo,
|
|
JclOtaResources;
|
|
|
|
type
|
|
TJclMMContentType = (mt8Bytes, mt4Words, mt2DWords, mt1QWord, mt2Singles);
|
|
|
|
TJclMMRegister = packed record
|
|
case TJclMMContentType of
|
|
mt8Bytes:
|
|
(Bytes: array [0..7] of Byte;);
|
|
mt4Words:
|
|
(Words: array [0..3] of Word;);
|
|
mt2DWords:
|
|
(DWords: array [0..1] of Cardinal;);
|
|
mt1QWord:
|
|
(QWords: Int64;);
|
|
mt2Singles:
|
|
(Singles: array [0..1] of Single;);
|
|
end;
|
|
|
|
TJclFPUContentType = (ftExtended, ftMM);
|
|
|
|
TJclFPUData = packed record
|
|
case TJclFPUContentType of
|
|
ftExtended:
|
|
(FloatValue: Extended;);
|
|
ftMM:
|
|
(MMRegister: TJclMMRegister;
|
|
Reserved: Word;);
|
|
end;
|
|
|
|
TJclFPURegister = packed record
|
|
Data: TJclFPUData;
|
|
Reserved: array [0..5] of Byte;
|
|
end;
|
|
|
|
TJclFPURegisters = array [0..7] of TJclFPURegister;
|
|
|
|
TJclXMMContentType = (xt16Bytes, xt8Words, xt4DWords, xt2QWords, xt4Singles, xt2Doubles);
|
|
|
|
TJclXMMRegister = packed record
|
|
case TJclXMMContentType of
|
|
xt16Bytes:
|
|
(Bytes: array [0..15] of Byte;);
|
|
xt8Words:
|
|
(Words: array [0..7] of Word;);
|
|
xt4DWords:
|
|
(DWords: array [0..3] of Cardinal;);
|
|
xt2QWords:
|
|
(QWords: array [0..1] of Int64;);
|
|
xt4Singles:
|
|
(Singles: array [0..3] of Single;);
|
|
xt2Doubles:
|
|
(Doubles: array [0..1] of Double;);
|
|
end;
|
|
|
|
TJclProcessorSize = (ps32Bits, ps64Bits);
|
|
|
|
TJclXMMRegisters = packed record
|
|
case TJclProcessorSize of
|
|
ps32Bits:
|
|
(LegacyXMM: array [0..7] of TJclXMMRegister;
|
|
LegacyReserved: array [0..127] of Byte;);
|
|
ps64Bits:
|
|
(LongXMM: array [0..15] of TJclXMMRegister;);
|
|
end;
|
|
|
|
//TJclRoundingControl = (rcRoundToNearest, //=0
|
|
// rcRoundDown, //=1
|
|
// rcRoundUp, //=2
|
|
// rcRoundTowardZero); //=3
|
|
|
|
TJclVectorFrame = packed record
|
|
FCW: Word; // bytes from 0 to 1
|
|
FSW: Word; // bytes from 2 to 3
|
|
FTW: Byte; // byte 4
|
|
Reserved1: Byte; // byte 5
|
|
FOP: Word; // bytes from 6 to 7
|
|
FpuIp: Cardinal; // bytes from 8 to 11
|
|
CS: Word; // bytes from 12 to 13
|
|
Reserved2: Word; // bytes from 14 to 15
|
|
FpuDp: Cardinal; // bytes from 16 to 19
|
|
DS: Word; // bytes from 20 to 21
|
|
Reserved3: Word; // bytes from 22 to 23
|
|
MXCSR: Cardinal; // bytes from 24 to 27
|
|
MXCSRMask: Cardinal; // bytes from 28 to 31
|
|
FPURegisters: TJclFPURegisters; // bytes from 32 to 159
|
|
XMMRegisters: TJclXMMRegisters; // bytes from 160 to 415
|
|
Reserved4: array [416..511] of Byte; // bytes from 416 to 512
|
|
end;
|
|
|
|
TJclContext = packed record
|
|
ScalarContext: Windows.TContext;
|
|
VectorContext: TJclVectorFrame;
|
|
end;
|
|
|
|
PJclContext = ^TJclContext;
|
|
|
|
TBitDescription = record
|
|
AndMask: Cardinal;
|
|
Shifting: Cardinal;
|
|
ShortName: string;
|
|
LongName: string;
|
|
end;
|
|
|
|
TMXCSRRange = 0..14;
|
|
|
|
const
|
|
MXCSRBitsDescriptions: array [TMXCSRRange] of TBitDescription =
|
|
(
|
|
(AndMask: MXCSR_IE; Shifting: 0; ShortName: RsVectorIE; LongName: RsVectorIEText),
|
|
(AndMask: MXCSR_DE; Shifting: 1; ShortName: RsVectorDE; LongName: RsVectorDEText),
|
|
(AndMask: MXCSR_ZE; Shifting: 2; ShortName: RsVectorZE; LongName: RsVectorZEText),
|
|
(AndMask: MXCSR_OE; Shifting: 3; ShortName: RsVectorOE; LongName: RsVectorOEText),
|
|
(AndMask: MXCSR_UE; Shifting: 4; ShortName: RsVectorUE; LongName: RsVectorUEText),
|
|
(AndMask: MXCSR_PE; Shifting: 5; ShortName: RsVectorPE; LongName: RsVectorPEText),
|
|
(AndMask: MXCSR_DAZ; Shifting: 6; ShortName: RsVectorDAZ; LongName: RsVectorDAZText),
|
|
(AndMask: MXCSR_IM; Shifting: 7; ShortName: RsVectorIM; LongName: RsVectorIMText),
|
|
(AndMask: MXCSR_DM; Shifting: 8; ShortName: RsVectorDM; LongName: RsVectorDMText),
|
|
(AndMask: MXCSR_ZM; Shifting: 9; ShortName: RsVectorZM; LongName: RsVectorZMText),
|
|
(AndMask: MXCSR_OM; Shifting: 10; ShortName: RsVectorOM; LongName: RsVectorOMText),
|
|
(AndMask: MXCSR_UM; Shifting: 11; ShortName: RsVectorUM; LongName: RsVectorUMText),
|
|
(AndMask: MXCSR_PM; Shifting: 12; ShortName: RsVectorPM; LongName: RsVectorPMText),
|
|
(AndMask: MXCSR_RC; Shifting: 13; ShortName: RsVectorRC; LongName: RsVectorRCText),
|
|
(AndMask: MXCSR_FZ; Shifting: 15; ShortName: RsVectorFZ; LongName: RsVectorFZText)
|
|
);
|
|
|
|
type
|
|
TJclSIMDValue = packed record
|
|
case Display: TJclXMMContentType of
|
|
xt16Bytes:
|
|
(ValueByte: Byte;);
|
|
xt8Words:
|
|
(ValueWord: Word;);
|
|
xt4DWords:
|
|
(ValueDWord: Cardinal;);
|
|
xt2QWords:
|
|
(ValueQWord: Int64;);
|
|
xt4Singles:
|
|
(ValueSingle: Single;);
|
|
xt2Doubles:
|
|
(ValueDouble: Double;);
|
|
end;
|
|
|
|
TJclSIMDFormat = (sfBinary, sfSigned, sfUnsigned, sfHexa);
|
|
|
|
function FormatValue(Value: TJclSIMDValue; Format: TJclSIMDFormat): string;
|
|
function ParseValue(const StringValue: string; var Value: TJclSIMDValue;
|
|
Format: TJclSIMDFormat): Boolean;
|
|
function ReplaceSIMDRegisters(var Expression: string; Is64Bits: Boolean;
|
|
var VectorFrame: TJclVectorFrame): Boolean;
|
|
|
|
const
|
|
CONTEXT_EXTENDED_REGISTERS = CONTEXT_i386 or $00000020;
|
|
|
|
// return the processor frame for the specified thread, this thread must be suspended
|
|
function GetThreadContext(hThread: THandle; var lpContext: TJclContext): BOOL; stdcall;
|
|
|
|
// set the processor frame for the specified thread, this thread must be suspended
|
|
function SetThreadContext(hThread: THandle; const lpContext: TJclContext): BOOL; stdcall;
|
|
|
|
// return the XMM registers for the specified thread, this thread must be suspended
|
|
function GetVectorContext(AThread: IOTAThread; out VectorContext: TJclVectorFrame): Boolean;
|
|
// return the XMM registers for the specified thread, this thread must be suspended
|
|
function SetVectorContext(AThread: IOTAThread; const VectorContext: TJclVectorFrame): Boolean;
|
|
|
|
implementation
|
|
|
|
uses
|
|
SysUtils, Math,
|
|
JclOtaUtils;
|
|
|
|
function FormatBinary(Value: TJclSIMDValue): string;
|
|
var
|
|
I: Byte;
|
|
const
|
|
Width: array [xt16Bytes..xt2QWords] of Byte = (8, 16, 32, 64);
|
|
begin
|
|
if not (Value.Display in [xt16Bytes, xt8Words, xt4DWords, XT2QWords]) then
|
|
raise EJclExpertException.CreateTrace(RsEBadRegisterDisplay);
|
|
|
|
Assert(Value.Display < xt4Singles);
|
|
Result := StringOfChar('0', Width[Value.Display]);
|
|
for I := 1 to Width[Value.Display] do
|
|
begin
|
|
if (Value.ValueQWord and 1) <> 0 then
|
|
Result[Width[Value.Display] - I + 1] := '1';
|
|
Value.ValueQWord := Value.ValueQWord shr 1;
|
|
end;
|
|
end;
|
|
|
|
function FormatSigned(Value: TJclSIMDValue): string;
|
|
const
|
|
Width: array [xt16Bytes..xt2QWords] of Byte = (4, 6, 11, 20);
|
|
begin
|
|
if not (Value.Display in [xt16Bytes, xt8Words, xt4DWords, XT2QWords]) then
|
|
raise EJclExpertException.CreateTrace(RsEBadRegisterDisplay);
|
|
|
|
case Value.Display of
|
|
xt16Bytes:
|
|
Result := IntToStr(Shortint(Value.ValueByte));
|
|
xt8Words:
|
|
Result := IntToStr(Smallint(Value.ValueWord));
|
|
xt4DWords:
|
|
Result := IntToStr(Integer(Value.ValueDWord));
|
|
xt2QWords:
|
|
Result := IntToStr(Value.ValueQWord);
|
|
else
|
|
Result := '';
|
|
Exit;
|
|
end;
|
|
Result := StringOfChar(' ', Width[Value.Display] - Length(Result)) + Result;
|
|
end;
|
|
|
|
function FormatUnsigned(Value: TJclSIMDValue): string;
|
|
const
|
|
Width: array [xt16Bytes..xt2QWords] of Byte = (3, 5, 10, 20);
|
|
begin
|
|
if not (Value.Display in [xt16Bytes, xt8Words, xt4DWords, XT2QWords]) then
|
|
raise EJclExpertException.CreateTrace(RsEBadRegisterDisplay);
|
|
|
|
case Value.Display of
|
|
xt16Bytes:
|
|
Result := IntToStr(Byte(Value.ValueByte));
|
|
xt8Words:
|
|
Result := IntToStr(Word(Value.ValueWord));
|
|
xt4DWords:
|
|
Result := IntToStr(Cardinal(Value.ValueDWord));
|
|
xt2QWords:
|
|
Result := IntToStr(Value.ValueQWord);
|
|
else
|
|
Result := '';
|
|
Exit;
|
|
end;
|
|
Result := StringOfChar(' ', Width[Value.Display] - Length(Result)) + Result;
|
|
end;
|
|
|
|
function FormatHexa(Value: TJclSIMDValue): string;
|
|
const
|
|
Width: array [xt16Bytes..xt2QWords] of Byte = (2, 4, 8, 16);
|
|
begin
|
|
if not (Value.Display in [xt16Bytes, xt8Words, xt4DWords, XT2QWords]) then
|
|
raise EJclExpertException.CreateTrace(RsEBadRegisterDisplay);
|
|
|
|
case Value.Display of
|
|
xt16Bytes:
|
|
Result := IntToHex(Value.ValueByte, Width[xt16Bytes]);
|
|
xt8Words:
|
|
Result := IntToHex(Value.ValueWord, Width[xt8Words]);
|
|
xt4DWords:
|
|
Result := IntToHex(Value.ValueDWord, Width[xt4DWords]);
|
|
xt2QWords:
|
|
Result := IntToHex(Value.ValueQWord, Width[xt2QWords]);
|
|
else
|
|
Result := '';
|
|
end;
|
|
end;
|
|
|
|
function FormatFloat(Value: TJclSIMDValue): string;
|
|
begin
|
|
if not (Value.Display in [xt4Singles, xt2Doubles]) then
|
|
raise EJclExpertException.CreateTrace(RsEBadRegisterDisplay);
|
|
|
|
case Value.Display of
|
|
xt4Singles:
|
|
Result := FloatToStr(Value.ValueSingle);
|
|
xt2Doubles:
|
|
Result := FloatToStr(Value.ValueDouble);
|
|
else
|
|
Result := '';
|
|
end;
|
|
Result := StringOfChar(' ', 22 - Length(Result)) + Result; // 22 = max string length of a double value
|
|
end;
|
|
|
|
function FormatValue(Value: TJclSIMDValue; Format: TJclSIMDFormat): string;
|
|
type
|
|
TFormatFunction = function(Value: TJclSIMDValue): string;
|
|
var
|
|
FormatFunction: TFormatFunction;
|
|
begin
|
|
Result := '';
|
|
case Format of
|
|
sfBinary:
|
|
FormatFunction := FormatBinary;
|
|
sfSigned:
|
|
FormatFunction := FormatSigned;
|
|
sfUnsigned:
|
|
FormatFunction := FormatUnsigned;
|
|
sfHexa:
|
|
FormatFunction := FormatHexa;
|
|
else
|
|
Exit;
|
|
end;
|
|
case Value.Display of
|
|
xt16Bytes..xt2QWords:
|
|
Result := FormatFunction(Value);
|
|
xt4Singles..xt2Doubles:
|
|
Result := FormatFloat(Value);
|
|
end;
|
|
end;
|
|
|
|
function ParseBinary(StringValue: string; var Value: TJclSIMDValue): Boolean;
|
|
var
|
|
TestValue: Int64;
|
|
Index: Integer;
|
|
begin
|
|
TestValue := 0;
|
|
Result := False;
|
|
if Length(StringValue) > 64 then
|
|
Exit;
|
|
for Index := 1 to Length(StringValue) do
|
|
begin
|
|
TestValue := TestValue shl 1;
|
|
case StringValue[Index] of
|
|
'0':
|
|
;
|
|
'1':
|
|
Inc(TestValue);
|
|
else
|
|
Exit;
|
|
end;
|
|
end;
|
|
Result := True;
|
|
case Value.Display of
|
|
xt16Bytes:
|
|
if (TestValue >= Byte($00)) and (TestValue <= Byte($FF)) then
|
|
Value.ValueByte := TestValue
|
|
else
|
|
Result := False;
|
|
xt8Words:
|
|
if (TestValue >= Word($0000)) and (TestValue <= Word($FFFF)) then
|
|
Value.ValueWord := TestValue
|
|
else
|
|
Result := False;
|
|
xt4DWords:
|
|
if (TestValue >= Cardinal($00000000)) and (TestValue <= Cardinal($FFFFFFFF)) then
|
|
Value.ValueDWord := TestValue
|
|
else
|
|
Result := False;
|
|
xt2QWords:
|
|
Value.ValueQWord := TestValue;
|
|
else
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
function ParseSigned(StringValue: string; var Value: TJclSIMDValue): Boolean;
|
|
var
|
|
TestValue: Int64;
|
|
ErrorCode: Integer;
|
|
begin
|
|
Val(StringValue, TestValue, ErrorCode);
|
|
Result := ErrorCode = 0;
|
|
if Result then
|
|
case Value.Display of
|
|
xt16Bytes:
|
|
if (TestValue >= Shortint($80)) and (TestValue <= Shortint($7F)) then
|
|
Value.ValueByte := TestValue
|
|
else
|
|
Result := False;
|
|
xt8Words:
|
|
if (TestValue >= Smallint($8000)) and (TestValue <= Smallint($7FFF)) then
|
|
Value.ValueWord := TestValue
|
|
else
|
|
Result := False;
|
|
xt4DWords:
|
|
if (TestValue >= Integer($80000000)) and (TestValue <= Integer($7FFFFFFF)) then
|
|
Value.ValueDWord := TestValue
|
|
else
|
|
Result := False;
|
|
xt2QWords:
|
|
Value.ValueQWord := TestValue;
|
|
else
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
function ParseUnsigned(StringValue: string; var Value: TJclSIMDValue): Boolean;
|
|
var
|
|
TestValue: Int64;
|
|
ErrorCode: Integer;
|
|
begin
|
|
Val(StringValue, TestValue, ErrorCode);
|
|
Result := ErrorCode = 0;
|
|
if Result then
|
|
case Value.Display of
|
|
xt16Bytes:
|
|
if (TestValue >= Byte($00)) and (TestValue <= Byte($FF)) then
|
|
Value.ValueByte := TestValue
|
|
else
|
|
Result := False;
|
|
xt8Words:
|
|
if (TestValue >= Word($0000)) and (TestValue <= Word($FFFF)) then
|
|
Value.ValueWord := TestValue
|
|
else
|
|
Result := False;
|
|
xt4DWords:
|
|
if (TestValue >= Cardinal($00000000)) and (TestValue <= Cardinal($FFFFFFFF)) then
|
|
Value.ValueDWord := TestValue
|
|
else
|
|
Result := False;
|
|
xt2QWords:
|
|
Value.ValueQWord := TestValue;
|
|
else
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
function ParseHexa(StringValue: string; var Value: TJclSIMDValue): Boolean;
|
|
var
|
|
TestValue: Int64;
|
|
Index: Integer;
|
|
begin
|
|
TestValue := 0;
|
|
Result := False;
|
|
if Length(StringValue) > 16 then
|
|
Exit;
|
|
for Index := 1 to Length(StringValue) do
|
|
begin
|
|
TestValue := TestValue shl 4;
|
|
case StringValue[Index] of
|
|
'0':
|
|
;
|
|
'1'..'9':
|
|
Inc(TestValue, Ord(StringValue[Index]) - Ord('0'));
|
|
'A'..'F':
|
|
Inc(TestValue, Ord(StringValue[Index]) - Ord('A') + 10);
|
|
'a'..'f':
|
|
Inc(TestValue, Ord(StringValue[Index]) - Ord('a') + 10);
|
|
else
|
|
Exit;
|
|
end;
|
|
end;
|
|
Result := True;
|
|
case Value.Display of
|
|
xt16Bytes:
|
|
if (TestValue >= Byte($00)) and (TestValue <= Byte($FF)) then
|
|
Value.ValueByte := TestValue
|
|
else
|
|
Result := False;
|
|
xt8Words:
|
|
if (TestValue >= Word($0000)) and (TestValue <= Word($FFFF)) then
|
|
Value.ValueWord := TestValue
|
|
else
|
|
Result := False;
|
|
xt4DWords:
|
|
if (TestValue >= Cardinal($00000000)) and (TestValue <= Cardinal($FFFFFFFF)) then
|
|
Value.ValueDWord := TestValue
|
|
else
|
|
Result := False;
|
|
xt2QWords:
|
|
Value.ValueQWord := TestValue;
|
|
else
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
function ParseFloat(StringValue: string; var Value: TJclSIMDValue): Boolean;
|
|
var
|
|
TestValue: Extended;
|
|
ErrorCode: Integer;
|
|
begin
|
|
if DecimalSeparator <> '.' then
|
|
StringValue := StringReplace(StringValue, DecimalSeparator, '.', [rfReplaceAll, rfIgnoreCase]);
|
|
Val(StringValue, TestValue, ErrorCode);
|
|
Result := ErrorCode = 0;
|
|
if Result then
|
|
case Value.Display of
|
|
xt4Singles:
|
|
if (TestValue >= -MaxSingle) and (TestValue <= MaxSingle) then
|
|
Value.ValueSingle := TestValue
|
|
else
|
|
Result := False;
|
|
xt2Doubles:
|
|
if (TestValue >= MaxDouble) and (TestValue <= MaxDouble) then
|
|
Value.ValueDouble := TestValue
|
|
else
|
|
Result := False;
|
|
else
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
function ParseValue(const StringValue: string; var Value: TJclSIMDValue;
|
|
Format: TJclSIMDFormat): Boolean;
|
|
type
|
|
TParseFunction = function(StringValue: string; var Value: TJclSIMDValue): Boolean;
|
|
var
|
|
ParseFunction: TParseFunction;
|
|
begin
|
|
Result := False;
|
|
case Format of
|
|
sfBinary:
|
|
ParseFunction := ParseBinary;
|
|
sfSigned:
|
|
ParseFunction := ParseSigned;
|
|
sfUnsigned:
|
|
ParseFunction := ParseUnsigned;
|
|
sfHexa:
|
|
ParseFunction := ParseHexa;
|
|
else
|
|
Exit;
|
|
end;
|
|
case Value.Display of
|
|
xt16Bytes..xt2QWords:
|
|
Result := ParseFunction(StringValue, Value);
|
|
xt4Singles..xt2Doubles:
|
|
Result := ParseFloat(StringValue, Value);
|
|
end;
|
|
end;
|
|
|
|
function ReplaceSIMDRegisters(var Expression: string; Is64Bits: Boolean;
|
|
var VectorFrame: TJclVectorFrame): Boolean;
|
|
var
|
|
LocalString: string;
|
|
RegisterPosition: Integer;
|
|
DataPosition: Integer;
|
|
DataType: string;
|
|
Index: Integer;
|
|
RegisterIndex: Integer;
|
|
DataIndex: Integer;
|
|
ErrorCode: Integer;
|
|
NumberOfXMMRegister: Integer;
|
|
AValue: TJclSIMDValue;
|
|
ValueStr: string;
|
|
OldLength: Integer;
|
|
begin
|
|
if Is64Bits then
|
|
NumberOfXMMRegister := 16
|
|
else
|
|
NumberOfXMMRegister := 8;
|
|
Result := False;
|
|
LocalString := AnsiUpperCase(Expression);
|
|
|
|
RegisterPosition := AnsiPos('XMM', LocalString);
|
|
while (RegisterPosition > 0) do
|
|
begin
|
|
for Index := RegisterPosition to Length(LocalString) do
|
|
if LocalString[Index] = '.' then
|
|
Break;
|
|
if Index >= Length(LocalString) then
|
|
Exit;
|
|
Val(Copy(LocalString, RegisterPosition + 3, Index - RegisterPosition - 3), RegisterIndex, ErrorCode);
|
|
if (ErrorCode <> 0) or (RegisterIndex < 0) or (RegisterIndex >= NumberOfXMMRegister) then
|
|
Exit;
|
|
|
|
DataPosition := Index + 1;
|
|
if DataPosition > Length(LocalString) then
|
|
Exit;
|
|
for Index := DataPosition to Length(LocalString) do
|
|
if LocalString[Index] in ['0'..'9'] then
|
|
Break;
|
|
if Index > Length(LocalString) then
|
|
Exit;
|
|
DataType := Copy(LocalString, DataPosition, Index - DataPosition);
|
|
|
|
DataPosition := Index;
|
|
for Index := DataPosition to Length(LocalString) do
|
|
if not (LocalString[Index] in ['0'..'9']) then
|
|
Break;
|
|
Val(Copy(LocalString, DataPosition, Index - DataPosition), DataIndex, ErrorCode);
|
|
if (ErrorCode <> 0) or (DataIndex < 0) then
|
|
Exit;
|
|
|
|
if CompareStr(DataType, 'BYTE') = 0 then
|
|
begin
|
|
if DataIndex >= 16 then
|
|
Exit;
|
|
AValue.Display := xt16Bytes;
|
|
AValue.ValueByte := VectorFrame.XMMRegisters.LongXMM[RegisterIndex].Bytes[DataIndex];
|
|
end
|
|
else
|
|
if CompareStr(DataType, 'WORD') = 0 then
|
|
begin
|
|
if DataIndex >= 8 then
|
|
Exit;
|
|
AValue.Display := xt8Words;
|
|
AValue.ValueWord := VectorFrame.XMMRegisters.LongXMM[RegisterIndex].Words[DataIndex];
|
|
end
|
|
else
|
|
if CompareStr(DataType, 'DWORD') = 0 then
|
|
begin
|
|
if DataIndex >= 4 then
|
|
Exit;
|
|
AValue.Display := xt4DWords;
|
|
AValue.ValueDWord := VectorFrame.XMMRegisters.LongXMM[RegisterIndex].DWords[DataIndex];
|
|
end
|
|
else
|
|
if CompareStr(DataType, 'QWORD') = 0 then
|
|
begin
|
|
if DataIndex >= 2 then
|
|
Exit;
|
|
AValue.Display := xt2QWords;
|
|
AValue.ValueQWord := VectorFrame.XMMRegisters.LongXMM[RegisterIndex].QWords[DataIndex];
|
|
end
|
|
else
|
|
if CompareStr(DataType, 'SINGLE') = 0 then
|
|
begin
|
|
if DataIndex >= 4 then
|
|
Exit;
|
|
AValue.Display := xt4Singles;
|
|
AValue.ValueSingle := VectorFrame.XMMRegisters.LongXMM[RegisterIndex].Singles[DataIndex];
|
|
end
|
|
else
|
|
if CompareStr(DataType, 'DOUBLE') = 0 then
|
|
begin
|
|
if DataIndex >= 2 then
|
|
Exit;
|
|
AValue.Display := xt2Doubles;
|
|
AValue.ValueDouble := VectorFrame.XMMRegisters.LongXMM[RegisterIndex].Doubles[DataIndex];
|
|
end
|
|
else
|
|
Exit;
|
|
ValueStr := Trim(FormatValue(AValue, sfSigned));
|
|
if DecimalSeparator <> '.' then
|
|
ValueStr := StringReplace(ValueStr, DecimalSeparator, '.', [rfReplaceAll, rfIgnoreCase]);
|
|
if Length(ValueStr) >= Index - RegisterPosition then
|
|
begin
|
|
OldLength := Length(Expression);
|
|
SetLength(Expression, Length(Expression) + Length(ValueStr) - (Index - RegisterPosition));
|
|
if Length(ValueStr) > Index - RegisterPosition then
|
|
Move(Expression[Index], Expression[RegisterPosition + Length(ValueStr)], OldLength - Index + 1);
|
|
Move(ValueStr[1], Expression[RegisterPosition], Length(ValueStr));
|
|
end
|
|
else
|
|
begin
|
|
Move(ValueStr[1], Expression[RegisterPosition], Length(ValueStr));
|
|
Move(Expression[Index], Expression[RegisterPosition + Length(ValueStr)], Length(Expression) - Index + 1);
|
|
SetLength(Expression, Length(Expression) + Length(ValueStr) - (Index - RegisterPosition));
|
|
end;
|
|
LocalString := AnsiUpperCase(Expression);
|
|
RegisterPosition := AnsiPos('XMM', LocalString);
|
|
end;
|
|
|
|
RegisterPosition := AnsiPos('MM', LocalString);
|
|
while (RegisterPosition > 0) do
|
|
begin
|
|
for Index := RegisterPosition to Length(LocalString) do
|
|
if LocalString[Index] = '.' then
|
|
Break;
|
|
if Index >= Length(LocalString) then
|
|
Exit;
|
|
Val(Copy(LocalString, RegisterPosition + 2, Index - RegisterPosition - 2), RegisterIndex, ErrorCode);
|
|
if (ErrorCode <> 0) or (RegisterIndex < 0) or (RegisterIndex >= 8) then
|
|
Exit;
|
|
|
|
DataPosition := Index + 1;
|
|
if DataPosition > Length(LocalString) then
|
|
Exit;
|
|
for Index := DataPosition to Length(LocalString) do
|
|
if LocalString[Index] in ['0'..'9'] then
|
|
Break;
|
|
if Index > Length(LocalString) then
|
|
Exit;
|
|
DataType := Copy(LocalString, DataPosition, Index - DataPosition);
|
|
|
|
DataPosition := Index;
|
|
for Index := DataPosition to Length(LocalString) do
|
|
if not (LocalString[Index] in ['0'..'9']) then
|
|
Break;
|
|
Val(Copy(LocalString, DataPosition, Index - DataPosition), DataIndex, ErrorCode);
|
|
if (ErrorCode <> 0) or (DataIndex < 0) then
|
|
Exit;
|
|
|
|
if CompareStr(DataType, 'BYTE') = 0 then
|
|
begin
|
|
if DataIndex >= 8 then
|
|
Exit;
|
|
AValue.Display := xt16Bytes;
|
|
AValue.ValueByte := VectorFrame.FPURegisters[RegisterIndex].Data.MMRegister.Bytes[DataIndex];
|
|
end
|
|
else
|
|
if CompareStr(DataType, 'WORD') = 0 then
|
|
begin
|
|
if DataIndex >= 4 then
|
|
Exit;
|
|
AValue.Display := xt8Words;
|
|
AValue.ValueWord := VectorFrame.FPURegisters[RegisterIndex].Data.MMRegister.Words[DataIndex];
|
|
end
|
|
else
|
|
if CompareStr(DataType, 'DWORD') = 0 then
|
|
begin
|
|
if DataIndex >= 2 then
|
|
Exit;
|
|
AValue.Display := xt4DWords;
|
|
AValue.ValueDWord := VectorFrame.FPURegisters[RegisterIndex].Data.MMRegister.DWords[DataIndex];
|
|
end
|
|
else
|
|
if CompareStr(DataType, 'QWORD') = 0 then
|
|
begin
|
|
if DataIndex >= 1 then
|
|
Exit;
|
|
AValue.Display := xt2QWords;
|
|
AValue.ValueQWord := VectorFrame.FPURegisters[RegisterIndex].Data.MMRegister.QWords;
|
|
end
|
|
else
|
|
if CompareStr(DataType, 'SINGLE') = 0 then
|
|
begin
|
|
if DataIndex >= 2 then
|
|
Exit;
|
|
AValue.Display := xt4Singles;
|
|
AValue.ValueSingle := VectorFrame.FPURegisters[RegisterIndex].Data.MMRegister.Singles[DataIndex];
|
|
end
|
|
else
|
|
Exit;
|
|
ValueStr := Trim(FormatValue(AValue, sfSigned));
|
|
if DecimalSeparator <> '.' then
|
|
ValueStr := StringReplace(ValueStr, DecimalSeparator, '.', [rfReplaceAll, rfIgnoreCase]);
|
|
if Length(ValueStr) >= Index - RegisterPosition then
|
|
begin
|
|
OldLength := Length(Expression);
|
|
SetLength(Expression, Length(Expression) + Length(ValueStr) - (Index - RegisterPosition));
|
|
if Length(ValueStr) > Index - RegisterPosition then
|
|
Move(Expression[Index], Expression[RegisterPosition + Length(ValueStr)], OldLength - Index + 1);
|
|
Move(ValueStr[1], Expression[RegisterPosition], Length(ValueStr));
|
|
end
|
|
else
|
|
begin
|
|
Move(ValueStr[1], Expression[RegisterPosition], Length(ValueStr));
|
|
Move(Expression[Index], Expression[RegisterPosition + Length(ValueStr)], Length(Expression) - Index + 1);
|
|
SetLength(Expression, Length(Expression) + Length(ValueStr) - (Index - RegisterPosition));
|
|
end;
|
|
LocalString := AnsiUpperCase(Expression);
|
|
RegisterPosition := AnsiPos('MM', LocalString);
|
|
end;
|
|
|
|
Result := True;
|
|
end;
|
|
|
|
function GetThreadContext(hThread: THandle;
|
|
var lpContext: TJclContext): BOOL; stdcall; external kernel32 name 'GetThreadContext';
|
|
|
|
function SetThreadContext(hThread: THandle;
|
|
const lpContext: TJclContext): BOOL; stdcall; external kernel32 name 'SetThreadContext';
|
|
|
|
function GetVectorContext(AThread: IOTAThread; out VectorContext: TJclVectorFrame): Boolean;
|
|
{$IFDEF COMPILER9_UP}
|
|
var
|
|
OTAXMMRegs: TOTAXMMRegs;
|
|
OTAThreadContext: TOTAThreadContext;
|
|
begin
|
|
Result := AThread.GetOTAXMMRegisters(OTAXMMRegs);
|
|
if Result then
|
|
begin
|
|
VectorContext.MXCSR := OTAXMMRegs.MXCSR;
|
|
VectorContext.MXCSRMask := $FFFFFFFF;
|
|
Move(OTAXMMRegs,VectorContext.XMMRegisters, SizeOf(TOTAXMMReg) * 8);
|
|
OTAThreadContext := AThread.OTAThreadContext;
|
|
VectorContext.FCW := OTAThreadContext.FloatSave.ControlWord;
|
|
VectorContext.FSW := OTAThreadContext.FloatSave.StatusWord;
|
|
VectorContext.FTW := OTAThreadContext.FloatSave.TagWord;
|
|
Move(OTAThreadContext.FloatSave.RegisterArea[00],VectorContext.FPURegisters[0],SizeOf(Extended));
|
|
Move(OTAThreadContext.FloatSave.RegisterArea[10],VectorContext.FPURegisters[1],SizeOf(Extended));
|
|
Move(OTAThreadContext.FloatSave.RegisterArea[20],VectorContext.FPURegisters[2],SizeOf(Extended));
|
|
Move(OTAThreadContext.FloatSave.RegisterArea[30],VectorContext.FPURegisters[3],SizeOf(Extended));
|
|
Move(OTAThreadContext.FloatSave.RegisterArea[40],VectorContext.FPURegisters[4],SizeOf(Extended));
|
|
Move(OTAThreadContext.FloatSave.RegisterArea[50],VectorContext.FPURegisters[5],SizeOf(Extended));
|
|
Move(OTAThreadContext.FloatSave.RegisterArea[60],VectorContext.FPURegisters[6],SizeOf(Extended));
|
|
Move(OTAThreadContext.FloatSave.RegisterArea[70],VectorContext.FPURegisters[7],SizeOf(Extended));
|
|
end;
|
|
end;
|
|
{$ELSE COMPILER9_UP}
|
|
var
|
|
ContextMemory: Pointer;
|
|
JvContext: PJclContext;
|
|
begin
|
|
GetMem(ContextMemory, SizeOf(TJclContext) + 15);
|
|
try
|
|
if (Cardinal(ContextMemory) and 15) <> 0 then
|
|
JvContext := PJclContext((Cardinal(ContextMemory) + 16) and $FFFFFFF0)
|
|
else
|
|
JvContext := ContextMemory;
|
|
JvContext^.ScalarContext.ContextFlags := CONTEXT_EXTENDED_REGISTERS;
|
|
Result := GetThreadContext(AThread.Handle,JvContext^) and
|
|
((JvContext^.ScalarContext.ContextFlags and CONTEXT_EXTENDED_REGISTERS)<>0);
|
|
if Result then
|
|
VectorContext := JvContext^.VectorContext
|
|
else
|
|
FillChar(VectorContext, SizeOf(VectorContext), 0);
|
|
finally
|
|
FreeMem(ContextMemory);
|
|
end;
|
|
end;
|
|
{$ENDIF COMPILER9_UP}
|
|
|
|
function SetVectorContext(AThread: IOTAThread; const VectorContext: TJclVectorFrame): Boolean;
|
|
{$IFDEF COMPILER9_UP}
|
|
var
|
|
OTAXMMRegs: TOTAXMMRegs;
|
|
begin
|
|
Result := True;
|
|
try
|
|
OTAXMMRegs.MXCSR := VectorContext.MXCSR;
|
|
Move(VectorContext.XMMRegisters,OTAXMMRegs,SizeOf(TOTAXMMReg) * 8);
|
|
AThread.SetOTAXMMRegisters(OTAXMMRegs);
|
|
except
|
|
Result := False;
|
|
end;
|
|
end;
|
|
{$ELSE COMPILER9_UP}
|
|
// MM registers can not saved (changes are overriden by the Borland's debugger)
|
|
{const
|
|
CONTEXT_FLAGS = CONTEXT_CONTROL or CONTEXT_INTEGER or CONTEXT_SEGMENTS
|
|
or CONTEXT_FLOATING_POINT or CONTEXT_EXTENDED_REGISTERS;
|
|
var
|
|
ContextMemory: Pointer;
|
|
JvContext: PJclContext;
|
|
Index: Integer;
|
|
begin
|
|
GetMem(ContextMemory,SizeOf(TJclContext)+15);
|
|
try
|
|
if ((Cardinal(ContextMemory) and 15)<>0) then
|
|
JvContext := PJclContext((Cardinal(ContextMemory)+16) and $FFFFFFF0)
|
|
else
|
|
JvContext := ContextMemory;
|
|
JvContext^.ScalarContext.ContextFlags := CONTEXT_FLAGS;
|
|
Result := GetThreadContext(hThread,JvContext^) and
|
|
((JvContext^.ScalarContext.ContextFlags and CONTEXT_FLAGS) = CONTEXT_FLAGS);
|
|
if (Result) then
|
|
begin
|
|
JvContext^.ScalarContext.ContextFlags := CONTEXT_FLAGS;
|
|
JvContext^.VectorContext := VectorContext;
|
|
for Index := 0 to 7 do
|
|
Move(VectorContext.FPURegisters[Index].Data.FloatValue,JvContext^.ScalarContext.FloatSave.RegisterArea[Index*SizeOf(Extended)],SizeOf(Extended));
|
|
Result := SetThreadContext(hThread,JvContext^);
|
|
end;
|
|
finally
|
|
FreeMem(ContextMemory);
|
|
end;
|
|
end;}
|
|
var
|
|
ContextMemory: Pointer;
|
|
JvContext: PJclContext;
|
|
begin
|
|
GetMem(ContextMemory, SizeOf(TJclContext) + 15);
|
|
try
|
|
if (Cardinal(ContextMemory) and 15) <> 0 then
|
|
JvContext := PJclContext((Cardinal(ContextMemory) + 16) and $FFFFFFF0)
|
|
else
|
|
JvContext := ContextMemory;
|
|
JvContext^.ScalarContext.ContextFlags := CONTEXT_EXTENDED_REGISTERS;
|
|
Result := GetThreadContext(AThread.Handle,JvContext^) and
|
|
((JvContext^.ScalarContext.ContextFlags and CONTEXT_EXTENDED_REGISTERS) = CONTEXT_EXTENDED_REGISTERS);
|
|
if Result then
|
|
Result := SetThreadContext(AThread.Handle,JvContext^);
|
|
finally
|
|
FreeMem(ContextMemory);
|
|
end;
|
|
end;
|
|
{$ENDIF COMPILER9_UP}
|
|
|
|
// History:
|
|
|
|
// $Log: JclSIMDUtils.pas,v $
|
|
// Revision 1.6 2005/12/16 23:46:25 outchy
|
|
// Added expert stack form.
|
|
// Added code to display call stack on expert exception.
|
|
// Fixed package extension for D2006.
|
|
//
|
|
// Revision 1.5 2005/12/04 10:10:57 obones
|
|
// Borland Developer Studio 2006 support
|
|
//
|
|
// Revision 1.4 2005/11/21 21:25:40 outchy
|
|
// Modified the get/set methods of thread context for Delphi 2005
|
|
//
|
|
// Revision 1.3 2005/10/26 03:29:44 rrossmair
|
|
// - improved header information, added $Date: 2005/12/16 23:46:25 $ and $Log: JclSIMDUtils.pas,v $
|
|
// - improved header information, added $Date: 2005/12/16 23:46:25 $ and Revision 1.6 2005/12/16 23:46:25 outchy
|
|
// - improved header information, added $Date: 2005/12/16 23:46:25 $ and Added expert stack form.
|
|
// - improved header information, added $Date: 2005/12/16 23:46:25 $ and Added code to display call stack on expert exception.
|
|
// - improved header information, added $Date: 2005/12/16 23:46:25 $ and Fixed package extension for D2006.
|
|
// - improved header information, added $Date: 2005/12/16 23:46:25 $ and
|
|
// - improved header information, added $Date: 2005/12/16 23:46:25 $ and Revision 1.5 2005/12/04 10:10:57 obones
|
|
// - improved header information, added $Date: 2005/12/16 23:46:25 $ and Borland Developer Studio 2006 support
|
|
// - improved header information, added $Date: 2005/12/16 23:46:25 $ and CVS tags.
|
|
//
|
|
|
|
end.
|
|
|