{**************************************************************************************************}
{                                                                                                  }
{ 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                                                            }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ Last modified: $Date:: 2009-09-14 18:00:50 +0200 (lun., 14 sept. 2009)                         $ }
{ Revision:      $Rev:: 3012                                                                     $ }
{ Author:        $Author:: outchy                                                                $ }
{                                                                                                  }
{**************************************************************************************************}

unit JclSIMDUtils;

{$I jcl.inc}

interface

uses
  Windows,
  ToolsAPI,
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  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;

  TJclPackedContentType = (pctBytes, pctWords, pctDWords, pctQWords, pctSingles, pctDoubles);

  TJclXMMRegister = packed record
    case TJclPackedContentType of
      pctBytes:
        (Bytes: array [0..15] of Byte;);
      pctWords:
        (Words: array [0..7] of Word;);
      pctDWords:
        (DWords: array [0..3] of Cardinal;);
      pctQWords:
        (QWords: array [0..1] of Int64;);
      pctSingles:
        (Singles: array [0..3] of Single;);
      pctDoubles:
        (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 511
  end;

  // upper 128-bit of YMM registers (lower 128 bits are aliased to XMM registers)
  TJclYMMRegister = packed record
    case TJclPackedContentType of
      pctBytes:
        (Bytes: array [16..31] of Byte;);
      pctWords:
        (Words: array [8..15] of Word;);
      pctDWords:
        (DWords: array [4..7] of Cardinal;);
      pctQWords:
        (QWords: array [2..3] of Int64;);
      pctSingles:
        (Singles: array [4..7] of Single;);
      pctDoubles:
        (Doubles: array [2..3] of Double;);
  end;

  TJclXStateHeader = packed record
    XState_BV: Int64;
    Reserved: array [0..55] of Byte;
  end;

  TJclExtSaveArea2 = packed record
    case TJclProcessorSize of
      ps32Bits:
        (LegacyYMM: array [0..7] of TJclYMMRegister;
         LegacyReserved: array [0..127] of Byte;);
      ps64Bits:
        (LongYMM: array [0..15] of TJclYMMRegister;);
  end;
  PJclExtSaveArea2 = ^TJclExtSaveArea2;

  TJclXStateContext = packed record
    // vector context
    SaveArea: TJclVectorFrame;      // bytes 0 to 511
    Header: TJclXStateHeader;       // bytes 512 to 575
    ExtSaveArea2: TJclExtSaveArea2; // bytes 576 to 831
  end;

  TJclContext = packed record
    ScalarContext: Windows.TContext;
    ExtendedContext: TJclXStateContext;
  end;
  PJclContext = ^TJclContext;

  TBitDescription = record
    AndMask: Cardinal;
    Shifting: Cardinal;
    ShortName: PResStringRec;
    LongName: PResStringRec;
  end;

  TMXCSRRange = 0..14;

var
  MXCSRBitsDescriptions: array [TMXCSRRange] of TBitDescription =
   (
    (AndMask: MXCSR_IE;  Shifting: 0;  ShortName: nil; LongName: nil),
    (AndMask: MXCSR_DE;  Shifting: 1;  ShortName: nil; LongName: nil),
    (AndMask: MXCSR_ZE;  Shifting: 2;  ShortName: nil; LongName: nil),
    (AndMask: MXCSR_OE;  Shifting: 3;  ShortName: nil; LongName: nil),
    (AndMask: MXCSR_UE;  Shifting: 4;  ShortName: nil; LongName: nil),
    (AndMask: MXCSR_PE;  Shifting: 5;  ShortName: nil; LongName: nil),
    (AndMask: MXCSR_DAZ; Shifting: 6;  ShortName: nil; LongName: nil),
    (AndMask: MXCSR_IM;  Shifting: 7;  ShortName: nil; LongName: nil),
    (AndMask: MXCSR_DM;  Shifting: 8;  ShortName: nil; LongName: nil),
    (AndMask: MXCSR_ZM;  Shifting: 9;  ShortName: nil; LongName: nil),
    (AndMask: MXCSR_OM;  Shifting: 10; ShortName: nil; LongName: nil),
    (AndMask: MXCSR_UM;  Shifting: 11; ShortName: nil; LongName: nil),
    (AndMask: MXCSR_PM;  Shifting: 12; ShortName: nil; LongName: nil),
    (AndMask: MXCSR_RC;  Shifting: 13; ShortName: nil; LongName: nil),
    (AndMask: MXCSR_FZ;  Shifting: 15; ShortName: nil; LongName: nil)
   );

type
  TJclSIMDValue = packed record
    case Display: TJclPackedContentType of
      pctBytes:
        (ValueByte: Byte;);
      pctWords:
        (ValueWord: Word;);
      pctDWords:
        (ValueDWord: Cardinal;);
      pctQWords:
        (ValueQWord: Int64;);
      pctSingles:
        (ValueSingle: Single;);
      pctDoubles:
        (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, YMMEnabled: Boolean;
  var JclContext: TJclContext): Boolean;

// return the XMM registers for the specified thread, this thread must be suspended
function GetThreadJclContext(AThread: IOTAThread; out JclContext: TJclContext): Boolean;
// return the XMM registers for the specified thread, this thread must be suspended
function SetThreadJclContext(AThread: IOTAThread; const JclContext: TJclContext): Boolean;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.1-Build3536/jcl/experts/debug/simdview/JclSIMDUtils.pas $';
    Revision: '$Revision: 3012 $';
    Date: '$Date: 2009-09-14 18:00:50 +0200 (lun., 14 sept. 2009) $';
    LogPath: 'JCL\experts\debug\simdview';
    Extra: '';
    Data: nil
    );
{$ENDIF UNITVERSIONING}

implementation

uses
  SysUtils, Math,
  JclStrings,
  JclSysUtils,
  JclWin32,
  JclOtaUtils;

function FormatBinary(Value: TJclSIMDValue): string;
var
  I: Byte;
const
  Width: array [pctBytes..pctQWords] of Byte = (8, 16, 32, 64);
begin
  if not (Value.Display in [pctBytes, pctWords, pctDWords, pctQWords]) then
    raise EJclExpertException.CreateRes(@RsEBadRegisterDisplay);

  Assert(Value.Display < pctSingles);
  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 [pctBytes..pctQWords] of Byte = (4, 6, 11, 20);
begin
  if not (Value.Display in [pctBytes, pctWords, pctDWords, pctQWords]) then
    raise EJclExpertException.CreateRes(@RsEBadRegisterDisplay);
    
  case Value.Display of
    pctBytes:
      Result := IntToStr(Shortint(Value.ValueByte));
    pctWords:
      Result := IntToStr(Smallint(Value.ValueWord));
    pctDWords:
      Result := IntToStr(Integer(Value.ValueDWord));
    pctQWords:
      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 [pctBytes..pctQWords] of Byte = (3, 5, 10, 20);
begin
  if not (Value.Display in [pctBytes, pctWords, pctDWords, pctQWords]) then
    raise EJclExpertException.CreateRes(@RsEBadRegisterDisplay);
    
  case Value.Display of
    pctBytes:
      Result := IntToStr(Byte(Value.ValueByte));
    pctWords:
      Result := IntToStr(Word(Value.ValueWord));
    pctDWords:
      Result := IntToStr(Cardinal(Value.ValueDWord));
    pctQWords:
      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 [pctBytes..pctQWords] of Byte = (2, 4, 8, 16);
begin
  if not (Value.Display in [pctBytes, pctWords, pctDWords, pctQWords]) then
    raise EJclExpertException.CreateRes(@RsEBadRegisterDisplay);
    
  case Value.Display of
    pctBytes:
      Result := IntToHex(Value.ValueByte, Width[pctBytes]);
    pctWords:
      Result := IntToHex(Value.ValueWord, Width[pctWords]);
    pctDWords:
      Result := IntToHex(Value.ValueDWord, Width[pctDWords]);
    pctQWords:
      Result := IntToHex(Value.ValueQWord, Width[pctQWords]);
  else
    Result := '';
  end;
end;

function FormatFloat(Value: TJclSIMDValue): string;
begin
  if not (Value.Display in [pctSingles, pctDoubles]) then
    raise EJclExpertException.CreateRes(@RsEBadRegisterDisplay);
    
  case Value.Display of
    pctSingles:
      Result := FloatToStr(Value.ValueSingle);
    pctDoubles:
      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
    pctBytes..pctQWords:
      Result := FormatFunction(Value);
    pctSingles..pctDoubles:
      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
    pctBytes:
      if (TestValue >= Byte($00)) and (TestValue <= Byte($FF)) then
        Value.ValueByte := TestValue
      else
        Result := False;
    pctWords:
      if (TestValue >= Word($0000)) and (TestValue <= Word($FFFF)) then
        Value.ValueWord := TestValue
      else
        Result := False;
    pctDWords:
      if (TestValue >= Cardinal($00000000)) and (TestValue <= Cardinal($FFFFFFFF)) then
        Value.ValueDWord := TestValue
      else
        Result := False;
    pctQWords:
      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
      pctBytes:
        if (TestValue >= Shortint($80)) and (TestValue <= Shortint($7F)) then
          Value.ValueByte := TestValue
        else
          Result := False;
      pctWords:
        if (TestValue >= Smallint($8000)) and (TestValue <= Smallint($7FFF)) then
          Value.ValueWord := TestValue
        else
          Result := False;
      pctDWords:
        if (TestValue >= Integer($80000000)) and (TestValue <= Integer($7FFFFFFF)) then
          Value.ValueDWord := TestValue
        else
          Result := False;
      pctQWords:
        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
      pctBytes:
        if (TestValue >= Byte($00)) and (TestValue <= Byte($FF)) then
          Value.ValueByte := TestValue
        else
          Result := False;
      pctWords:
        if (TestValue >= Word($0000)) and (TestValue <= Word($FFFF)) then
          Value.ValueWord := TestValue
        else
          Result := False;
      pctDWords:
        if (TestValue >= Cardinal($00000000)) and (TestValue <= Cardinal($FFFFFFFF)) then
          Value.ValueDWord := TestValue
        else
          Result := False;
      pctQWords:
        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
    pctBytes:
      if (TestValue >= Byte($00)) and (TestValue <= Byte($FF)) then
        Value.ValueByte := TestValue
      else
        Result := False;
    pctWords:
      if (TestValue >= Word($0000)) and (TestValue <= Word($FFFF)) then
        Value.ValueWord := TestValue
      else
        Result := False;
    pctDWords:
      if (TestValue >= Cardinal($00000000)) and (TestValue <= Cardinal($FFFFFFFF)) then
        Value.ValueDWord := TestValue
      else
        Result := False;
    pctQWords:
      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
      pctSingles:
        if (TestValue >= -MaxSingle) and (TestValue <= MaxSingle) then
          Value.ValueSingle := TestValue
        else
          Result := False;
      pctDoubles:
        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
    pctBytes..pctQWords:
      Result := ParseFunction(StringValue, Value);
    pctSingles..pctDoubles:
      Result := ParseFloat(StringValue, Value);
  end;
end;

function ReplaceSIMDRegisters(var Expression: string; Is64Bits, YMMEnabled: Boolean;
  var JclContext: TJclContext): 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;
  XMMMatch: Boolean;
begin
  if Is64Bits then
    NumberOfXMMRegister := 16
  else
    NumberOfXMMRegister := 8;
  Result := False;
  LocalString := AnsiUpperCase(Expression);

  XMMMatch := False;
  RegisterPosition := AnsiPos('XMM', LocalString);
  if YMMEnabled and (RegisterPosition = 0) then
    RegisterPosition := AnsiPos('YMM', LocalString)
  else
    XMMMatch := True;
  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 CharIsDigit(LocalString[Index]) 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 CharIsDigit(LocalString[Index]) 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
      AValue.Display := pctBytes;
      if DataIndex >= Low(JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].Bytes) then
      begin
        if XMMMatch then
          Exit;
        AValue.ValueByte := JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].Bytes[DataIndex];
      end
      else
        AValue.ValueByte := JclContext.ExtendedContext.SaveArea.XMMRegisters.LongXMM[RegisterIndex].Bytes[DataIndex];
    end
    else
    if CompareStr(DataType, 'WORD') = 0 then
    begin
      AValue.Display := pctWords;
      if DataIndex >= Low(JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].Words) then
      begin
        if XMMMatch then
          Exit;
        AValue.ValueWord := JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].Words[DataIndex];
      end
      else
        AValue.ValueWord := JclContext.ExtendedContext.SaveArea.XMMRegisters.LongXMM[RegisterIndex].Words[DataIndex];
    end
    else
    if CompareStr(DataType, 'DWORD') = 0 then
    begin
      AValue.Display := pctDWords;
      if DataIndex >= Low(JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].DWords) then
      begin
        if XMMMatch then
          Exit;
        AValue.ValueDWord := JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].DWords[DataIndex];
      end
      else
        AValue.ValueDWord := JclContext.ExtendedContext.SaveArea.XMMRegisters.LongXMM[RegisterIndex].DWords[DataIndex];
    end
    else
    if CompareStr(DataType, 'QWORD') = 0 then
    begin
      AValue.Display := pctQWords;
      if DataIndex >= Low(JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].QWords) then
      begin
        if XMMMatch then
          Exit;
        AValue.ValueQWord := JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].QWords[DataIndex];
      end
      else
        AValue.ValueQWord := JclContext.ExtendedContext.SaveArea.XMMRegisters.LongXMM[RegisterIndex].QWords[DataIndex];
    end
    else
    if CompareStr(DataType, 'SINGLE') = 0 then
    begin
      AValue.Display := pctSingles;
      if DataIndex >= Low(JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].Singles) then
      begin
        if XMMMatch then
          Exit;
        AValue.ValueSingle := JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].Singles[DataIndex];
      end
      else
        AValue.ValueSingle := JclContext.ExtendedContext.SaveArea.XMMRegisters.LongXMM[RegisterIndex].Singles[DataIndex];
    end
    else
    if CompareStr(DataType, 'DOUBLE') = 0 then
    begin
      AValue.Display := pctDoubles;
      if DataIndex >= Low(JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].Doubles) then
      begin
        if XMMMatch then
          Exit;
        AValue.ValueDouble := JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].Doubles[DataIndex];
      end
      else
        AValue.ValueDouble := JclContext.ExtendedContext.SaveArea.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);
    XMMMatch := False;
    RegisterPosition := AnsiPos('XMM', LocalString);
    if YMMEnabled and (RegisterPosition = 0) then
      RegisterPosition := AnsiPos('YMM', LocalString)
    else
      XMMMatch := True;
  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 CharIsDigit(LocalString[Index]) 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 CharIsDigit(LocalString[Index]) 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 := pctBytes;
      AValue.ValueByte := JclContext.ExtendedContext.SaveArea.FPURegisters[RegisterIndex].Data.MMRegister.Bytes[DataIndex];
    end
    else
    if CompareStr(DataType, 'WORD') = 0 then
    begin
      if DataIndex >= 4 then
        Exit;
      AValue.Display := pctWords;
      AValue.ValueWord := JclContext.ExtendedContext.SaveArea.FPURegisters[RegisterIndex].Data.MMRegister.Words[DataIndex];
    end
    else
    if CompareStr(DataType, 'DWORD') = 0 then
    begin
      if DataIndex >= 2 then
        Exit;
      AValue.Display := pctDWords;
      AValue.ValueDWord := JclContext.ExtendedContext.SaveArea.FPURegisters[RegisterIndex].Data.MMRegister.DWords[DataIndex];
    end
    else
    if CompareStr(DataType, 'QWORD') = 0 then
    begin
      if DataIndex >= 1 then
        Exit;
      AValue.Display := pctQWords;
      AValue.ValueQWord := JclContext.ExtendedContext.SaveArea.FPURegisters[RegisterIndex].Data.MMRegister.QWords;
    end
    else
    if CompareStr(DataType, 'SINGLE') = 0 then
    begin
      if DataIndex >= 2 then
        Exit;
      AValue.Display := pctSingles;
      AValue.ValueSingle := JclContext.ExtendedContext.SaveArea.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;

// return the processor frame for the specified thread, this thread must be suspended
function GetThreadContext(hThread: THandle; lpContext: Pointer): BOOL; stdcall; external kernel32 name 'GetThreadContext';

// set the processor frame for the specified thread, this thread must be suspended
function SetThreadContext(hThread: THandle; lpContext: Pointer): BOOL; stdcall; external kernel32 name 'SetThreadContext';

function GetThreadJclContext(AThread: IOTAThread; out JclContext: TJclContext): Boolean;
var
  {$IFDEF COMPILER9_UP}
  OTAXMMRegs: TOTAXMMRegs;
  OTAThreadContext: TOTAThreadContext;
  {$ELSE ~COMPILER9_UP}
  ContextMemory: Pointer;
  AlignedContext: PJclContext;
  {$ENDIF ~COMPILER9_UP}
  ExtendedContextLength: DWORD;
  ExtendedContextMemory: Pointer;
  ExtendedContext: PCONTEXT_EX;
  LegacyContext: PContext;
  AVXContext: PJclExtSaveArea2;
begin
  // get YMM registers
  if oefAVX in GetOSEnabledFeatures then
  begin
    // allocate enough memory to get this extended context
    Result := GetExtendedContextLength(CONTEXT_XSTATE, @ExtendedContextLength);
    if Result then
    begin
      GetMem(ExtendedContextMemory, ExtendedContextLength);
      try
        Result := InitializeExtendedContext(ExtendedContextMemory, CONTEXT_XSTATE, ExtendedContext);
        if Result then
        begin
          // find usefull part locations in this extended context
          LegacyContext := LocateLegacyContext(ExtendedContext, nil);
          AVXContext := LocateExtendedFeature(ExtendedContext, XSTATE_GSSE, nil);
          // get the context
          Result := GetThreadContext(AThread.Handle, LegacyContext) and
            ((LegacyContext.ContextFlags and CONTEXT_XSTATE) <> 0);
          if Result then
            // copy the data
            JclContext.ExtendedContext.ExtSaveArea2 := AVXContext^
          else
            ResetMemory(JclContext.ExtendedContext.ExtSaveArea2, SizeOf(JclContext.ExtendedContext.ExtSaveArea2));
        end;
      finally
        FreeMem(ExtendedContextMemory);
      end;
    end;
  end
  else
  begin
    Result := True;
    ResetMemory(JclContext.ExtendedContext.ExtSaveArea2, SizeOf(JclContext.ExtendedContext.ExtSaveArea2));
  end;
  {$IFDEF COMPILER9_UP}
  // get XMM registers
  if Result then
    Result := AThread.GetOTAXMMRegisters(OTAXMMRegs);
  if Result then
  begin
    // get other registers
    JclContext.ExtendedContext.SaveArea.MXCSR := OTAXMMRegs.MXCSR;
    JclContext.ExtendedContext.SaveArea.MXCSRMask := $FFFFFFFF;
    Move(OTAXMMRegs,JclContext.ExtendedContext.SaveArea.XMMRegisters, SizeOf(TOTAXMMReg) * 8);
    OTAThreadContext := AThread.OTAThreadContext;
    JclContext.ExtendedContext.SaveArea.FCW := OTAThreadContext.FloatSave.ControlWord;
    JclContext.ExtendedContext.SaveArea.FSW := OTAThreadContext.FloatSave.StatusWord;
    JclContext.ExtendedContext.SaveArea.FTW := OTAThreadContext.FloatSave.TagWord;
    Move(OTAThreadContext.FloatSave.RegisterArea[00],JclContext.ExtendedContext.SaveArea.FPURegisters[0],SizeOf(Extended));
    Move(OTAThreadContext.FloatSave.RegisterArea[10],JclContext.ExtendedContext.SaveArea.FPURegisters[1],SizeOf(Extended));
    Move(OTAThreadContext.FloatSave.RegisterArea[20],JclContext.ExtendedContext.SaveArea.FPURegisters[2],SizeOf(Extended));
    Move(OTAThreadContext.FloatSave.RegisterArea[30],JclContext.ExtendedContext.SaveArea.FPURegisters[3],SizeOf(Extended));
    Move(OTAThreadContext.FloatSave.RegisterArea[40],JclContext.ExtendedContext.SaveArea.FPURegisters[4],SizeOf(Extended));
    Move(OTAThreadContext.FloatSave.RegisterArea[50],JclContext.ExtendedContext.SaveArea.FPURegisters[5],SizeOf(Extended));
    Move(OTAThreadContext.FloatSave.RegisterArea[60],JclContext.ExtendedContext.SaveArea.FPURegisters[6],SizeOf(Extended));
    Move(OTAThreadContext.FloatSave.RegisterArea[70],JclContext.ExtendedContext.SaveArea.FPURegisters[7],SizeOf(Extended));
  end;
  {$ELSE COMPILER9_UP}
  // get XMM registers
  if Result then
  begin
    GetMem(ContextMemory, SizeOf(TJclContext) + 15);
    try
      if (Cardinal(ContextMemory) and 15) <> 0 then
        AlignedContext := PJclContext((Cardinal(ContextMemory) + 16) and $FFFFFFF0)
      else
        AlignedContext := ContextMemory;
      AlignedContext^.ScalarContext.ContextFlags := CONTEXT_EXTENDED_REGISTERS;
      Result := GetThreadContext(AThread.Handle,AlignedContext) and
        ((AlignedContext^.ScalarContext.ContextFlags and CONTEXT_EXTENDED_REGISTERS)<>0);
      ResetMemory(AlignedContext.ExtendedContext.ExtSaveArea2, SizeOf(AlignedContext.ExtendedContext.ExtSaveArea2));
      if Result then
        JclContext := AlignedContext^
      else
        ResetMemory(JclContext, SizeOf(JclContext));
    finally
      FreeMem(ContextMemory);
    end;
  end;
  {$ENDIF COMPILER9_UP}
end;

function SetThreadJclContext(AThread: IOTAThread; const JclContext: TJclContext): Boolean;
var
  {$IFDEF COMPILER9_UP}
  OTAXMMRegs: TOTAXMMRegs;
  {$ELSE ~COMPILER9_UP}
  ContextMemory: Pointer;
  AlignedContext: PJclContext;
  {$ENDIF ~COMPILER9_UP}
  ExtendedContextLength: DWORD;
  ExtendedContextMemory: Pointer;
  ExtendedContext: PCONTEXT_EX;
  LegacyContext: PContext;
  AVXContext: PJclExtSaveArea2;
begin
  // save YMM registers
  if oefAVX in GetOSEnabledFeatures then
  begin
    // allocate enough memory to get this extended context
    Result := GetExtendedContextLength(CONTEXT_XSTATE, @ExtendedContextLength);
    if Result then
    begin
      GetMem(ExtendedContextMemory, ExtendedContextLength);
      try
        Result := InitializeExtendedContext(ExtendedContextMemory, CONTEXT_XSTATE, ExtendedContext);
        if Result then
        begin
          // find usefull part locations in this extended context
          LegacyContext := LocateLegacyContext(ExtendedContext, nil);
          AVXContext := LocateExtendedFeature(ExtendedContext, XSTATE_GSSE, nil);
          // get the context
          Result := GetThreadContext(AThread.Handle, LegacyContext) and
            ((LegacyContext.ContextFlags and CONTEXT_XSTATE) <> 0);
          if Result then
          begin
            // copy the data
            AVXContext^ := JclContext.ExtendedContext.ExtSaveArea2;
            // set the context
            Result := SetThreadContext(AThread.Handle, LegacyContext);
          end;
        end;
      finally
        FreeMem(ExtendedContextMemory);
      end;
    end;
  end
  else
    Result := True;
  {$IFDEF COMPILER9_UP}
  if Result then
  begin
    try
      // save XMM registers
      OTAXMMRegs.MXCSR := JclContext.ExtendedContext.SaveArea.MXCSR;
      Move(JclContext.ExtendedContext.SaveArea.XMMRegisters,OTAXMMRegs,SizeOf(TOTAXMMReg) * 8);
      AThread.SetOTAXMMRegisters(OTAXMMRegs);
    except
      Result := False;
    end;
  end;
  {$ELSE ~COMPILER9_UP}
  if Result then
  begin
    GetMem(ContextMemory, SizeOf(TJclContext) + 15);
    try
      if (Cardinal(ContextMemory) and 15) <> 0 then
        AlignedContext := PJclContext((Cardinal(ContextMemory) + 16) and $FFFFFFF0)
      else
        AlignedContext := ContextMemory;
      AlignedContext^.ScalarContext.ContextFlags := CONTEXT_EXTENDED_REGISTERS;
      Result := GetThreadContext(AThread.Handle,AlignedContext) and
        ((AlignedContext^.ScalarContext.ContextFlags and CONTEXT_EXTENDED_REGISTERS) = CONTEXT_EXTENDED_REGISTERS);
      AlignedContext^ := JclContext;
      if Result then
        Result := SetThreadContext(AThread.Handle,AlignedContext);
      // TODO set the YMM registers
    finally
      FreeMem(ContextMemory);
    end;
  end;
  {$ENDIF COMPILER9_UP}
end;

{$IFDEF UNITVERSIONING}
initialization
  RegisterUnitVersion(HInstance, UnitVersioning);

finalization
  UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}

end.