PageRenderTime 27ms CodeModel.GetById 19ms app.highlight 4ms RepoModel.GetById 0ms app.codeStats 0ms

/jcl/experts/debug/simdview/JclSIMDUtils.pas

https://github.com/the-Arioch/jcl
Pascal | 1050 lines | 911 code | 65 blank | 74 comment | 107 complexity | 011689b54ac88659a67d316203058afa MD5 | raw file
Possible License(s): BSD-3-Clause
   1{**************************************************************************************************}
   2{                                                                                                  }
   3{ Project JEDI Code Library (JCL)                                                                  }
   4{                                                                                                  }
   5{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
   6{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
   7{ License at http://www.mozilla.org/MPL/                                                           }
   8{                                                                                                  }
   9{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
  10{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
  11{ and limitations under the License.                                                               }
  12{                                                                                                  }
  13{ The Original Code is: JvSIMDUtils.pas, released on 2004-10-11.                                   }
  14{                                                                                                  }
  15{ The Initial Developer of the Original Code is Florent Ouchet                                     }
  16{ [ouchet dott florent att laposte dott net]                                                       }
  17{ Portions created by Florent Ouchet are Copyright (C) 2004 Florent Ouchet.                        }
  18{ All Rights Reserved.                                                                             }
  19{                                                                                                  }
  20{ You may retrieve the latest version of this file at the Project JEDI's JCL home page,            }
  21{ located at http://jcl.sourceforge.net                                                            }
  22{                                                                                                  }
  23{**************************************************************************************************}
  24{                                                                                                  }
  25{ Last modified: $Date::                                                                         $ }
  26{ Revision:      $Rev::                                                                          $ }
  27{ Author:        $Author::                                                                       $ }
  28{                                                                                                  }
  29{**************************************************************************************************}
  30
  31unit JclSIMDUtils;
  32
  33{$I jcl.inc}
  34
  35interface
  36
  37uses
  38  Windows,
  39  ToolsAPI,
  40  {$IFDEF UNITVERSIONING}
  41  JclUnitVersioning,
  42  {$ENDIF UNITVERSIONING}
  43  JclSysInfo,
  44  JclOtaResources;
  45
  46type
  47  TJclMMContentType = (mt8Bytes, mt4Words, mt2DWords, mt1QWord, mt2Singles);
  48
  49  TJclMMRegister = packed record
  50    case TJclMMContentType of
  51      mt8Bytes:
  52        (Bytes: array [0..7] of Byte;);
  53      mt4Words:
  54        (Words: array [0..3] of Word;);
  55      mt2DWords:
  56        (DWords: array [0..1] of Cardinal;);
  57      mt1QWord:
  58        (QWords: Int64;);
  59      mt2Singles:
  60        (Singles: array [0..1] of Single;);
  61  end;
  62
  63  TJclFPUContentType = (ftExtended, ftMM);
  64
  65  TJclFPUData = packed record
  66    case TJclFPUContentType of
  67      ftExtended:
  68        (FloatValue: Extended;);
  69      ftMM:
  70        (MMRegister: TJclMMRegister;
  71         Reserved: Word;);
  72  end;
  73
  74  TJclFPURegister = packed record
  75    Data: TJclFPUData;
  76    Reserved: array [0..5] of Byte;
  77  end;
  78
  79  TJclFPURegisters = array [0..7] of TJclFPURegister;
  80
  81  TJclPackedContentType = (pctBytes, pctWords, pctDWords, pctQWords, pctSingles, pctDoubles);
  82
  83  TJclXMMRegister = packed record
  84    case TJclPackedContentType of
  85      pctBytes:
  86        (Bytes: array [0..15] of Byte;);
  87      pctWords:
  88        (Words: array [0..7] of Word;);
  89      pctDWords:
  90        (DWords: array [0..3] of Cardinal;);
  91      pctQWords:
  92        (QWords: array [0..1] of Int64;);
  93      pctSingles:
  94        (Singles: array [0..3] of Single;);
  95      pctDoubles:
  96        (Doubles: array [0..1] of Double;);
  97  end;
  98
  99  TJclProcessorSize = (ps32Bits, ps64Bits);
 100
 101  TJclXMMRegisters = packed record
 102    case TJclProcessorSize of
 103      ps32Bits:
 104        (LegacyXMM: array [0..7] of TJclXMMRegister;
 105         LegacyReserved: array [0..127] of Byte;);
 106      ps64Bits:
 107        (LongXMM: array [0..15] of TJclXMMRegister;);
 108  end;
 109
 110  //TJclRoundingControl = (rcRoundToNearest,   //=0
 111  //                       rcRoundDown,        //=1
 112  //                       rcRoundUp,          //=2
 113  //                       rcRoundTowardZero); //=3
 114
 115  TJclVectorFrame = packed record
 116    FCW: Word;                           // bytes from 0   to 1
 117    FSW: Word;                           // bytes from 2   to 3
 118    FTW: Byte;                           // byte 4
 119    Reserved1: Byte;                     // byte 5
 120    FOP: Word;                           // bytes from 6   to 7
 121    FpuIp: Cardinal;                     // bytes from 8   to 11
 122    CS: Word;                            // bytes from 12  to 13
 123    Reserved2: Word;                     // bytes from 14  to 15
 124    FpuDp: Cardinal;                     // bytes from 16  to 19
 125    DS: Word;                            // bytes from 20  to 21
 126    Reserved3: Word;                     // bytes from 22  to 23
 127    MXCSR: Cardinal;                     // bytes from 24  to 27
 128    MXCSRMask: Cardinal;                 // bytes from 28  to 31
 129    FPURegisters: TJclFPURegisters;      // bytes from 32  to 159
 130    XMMRegisters: TJclXMMRegisters;      // bytes from 160 to 415
 131    Reserved4: array [416..511] of Byte; // bytes from 416 to 511
 132  end;
 133
 134  // upper 128-bit of YMM registers (lower 128 bits are aliased to XMM registers)
 135  TJclYMMRegister = packed record
 136    case TJclPackedContentType of
 137      pctBytes:
 138        (Bytes: array [16..31] of Byte;);
 139      pctWords:
 140        (Words: array [8..15] of Word;);
 141      pctDWords:
 142        (DWords: array [4..7] of Cardinal;);
 143      pctQWords:
 144        (QWords: array [2..3] of Int64;);
 145      pctSingles:
 146        (Singles: array [4..7] of Single;);
 147      pctDoubles:
 148        (Doubles: array [2..3] of Double;);
 149  end;
 150
 151  TJclXStateHeader = packed record
 152    XState_BV: Int64;
 153    Reserved: array [0..55] of Byte;
 154  end;
 155
 156  TJclExtSaveArea2 = packed record
 157    case TJclProcessorSize of
 158      ps32Bits:
 159        (LegacyYMM: array [0..7] of TJclYMMRegister;
 160         LegacyReserved: array [0..127] of Byte;);
 161      ps64Bits:
 162        (LongYMM: array [0..15] of TJclYMMRegister;);
 163  end;
 164  PJclExtSaveArea2 = ^TJclExtSaveArea2;
 165
 166  TJclXStateContext = packed record
 167    // vector context
 168    SaveArea: TJclVectorFrame;      // bytes 0 to 511
 169    Header: TJclXStateHeader;       // bytes 512 to 575
 170    ExtSaveArea2: TJclExtSaveArea2; // bytes 576 to 831
 171  end;
 172
 173  TJclContext = packed record
 174    ScalarContext: Windows.TContext;
 175    ExtendedContext: TJclXStateContext;
 176  end;
 177  PJclContext = ^TJclContext;
 178
 179  TBitDescription = record
 180    AndMask: Cardinal;
 181    Shifting: Cardinal;
 182    ShortName: PResStringRec;
 183    LongName: PResStringRec;
 184  end;
 185
 186  TMXCSRRange = 0..14;
 187
 188var
 189  MXCSRBitsDescriptions: array [TMXCSRRange] of TBitDescription =
 190   (
 191    (AndMask: MXCSR_IE;  Shifting: 0;  ShortName: nil; LongName: nil),
 192    (AndMask: MXCSR_DE;  Shifting: 1;  ShortName: nil; LongName: nil),
 193    (AndMask: MXCSR_ZE;  Shifting: 2;  ShortName: nil; LongName: nil),
 194    (AndMask: MXCSR_OE;  Shifting: 3;  ShortName: nil; LongName: nil),
 195    (AndMask: MXCSR_UE;  Shifting: 4;  ShortName: nil; LongName: nil),
 196    (AndMask: MXCSR_PE;  Shifting: 5;  ShortName: nil; LongName: nil),
 197    (AndMask: MXCSR_DAZ; Shifting: 6;  ShortName: nil; LongName: nil),
 198    (AndMask: MXCSR_IM;  Shifting: 7;  ShortName: nil; LongName: nil),
 199    (AndMask: MXCSR_DM;  Shifting: 8;  ShortName: nil; LongName: nil),
 200    (AndMask: MXCSR_ZM;  Shifting: 9;  ShortName: nil; LongName: nil),
 201    (AndMask: MXCSR_OM;  Shifting: 10; ShortName: nil; LongName: nil),
 202    (AndMask: MXCSR_UM;  Shifting: 11; ShortName: nil; LongName: nil),
 203    (AndMask: MXCSR_PM;  Shifting: 12; ShortName: nil; LongName: nil),
 204    (AndMask: MXCSR_RC;  Shifting: 13; ShortName: nil; LongName: nil),
 205    (AndMask: MXCSR_FZ;  Shifting: 15; ShortName: nil; LongName: nil)
 206   );
 207
 208type
 209  TJclSIMDValue = packed record
 210    case Display: TJclPackedContentType of
 211      pctBytes:
 212        (ValueByte: Byte;);
 213      pctWords:
 214        (ValueWord: Word;);
 215      pctDWords:
 216        (ValueDWord: Cardinal;);
 217      pctQWords:
 218        (ValueQWord: Int64;);
 219      pctSingles:
 220        (ValueSingle: Single;);
 221      pctDoubles:
 222        (ValueDouble: Double;);
 223  end;
 224
 225  TJclSIMDFormat = (sfBinary, sfSigned, sfUnsigned, sfHexa);
 226
 227function FormatValue(Value: TJclSIMDValue; Format: TJclSIMDFormat): string;
 228function ParseValue(const StringValue: string; var Value: TJclSIMDValue;
 229  Format: TJclSIMDFormat): Boolean;
 230function ReplaceSIMDRegisters(var Expression: string; Is64Bits, YMMEnabled: Boolean;
 231  var JclContext: TJclContext): Boolean;
 232
 233// return the XMM registers for the specified thread, this thread must be suspended
 234function GetThreadJclContext(AThread: IOTAThread; out JclContext: TJclContext): Boolean;
 235// return the XMM registers for the specified thread, this thread must be suspended
 236function SetThreadJclContext(AThread: IOTAThread; const JclContext: TJclContext): Boolean;
 237
 238{$IFDEF UNITVERSIONING}
 239const
 240  UnitVersioning: TUnitVersionInfo = (
 241    RCSfile: '$URL$';
 242    Revision: '$Revision$';
 243    Date: '$Date$';
 244    LogPath: 'JCL\experts\debug\simdview';
 245    Extra: '';
 246    Data: nil
 247    );
 248{$ENDIF UNITVERSIONING}
 249
 250implementation
 251
 252uses
 253  SysUtils, Math,
 254  JclStrings,
 255  JclSysUtils,
 256  JclWin32,
 257  JclOtaUtils;
 258
 259function FormatBinary(Value: TJclSIMDValue): string;
 260var
 261  I: Byte;
 262const
 263  Width: array [pctBytes..pctQWords] of Byte = (8, 16, 32, 64);
 264begin
 265  if not (Value.Display in [pctBytes, pctWords, pctDWords, pctQWords]) then
 266    raise EJclExpertException.CreateRes(@RsEBadRegisterDisplay);
 267
 268  Assert(Value.Display < pctSingles);
 269  Result := StringOfChar('0', Width[Value.Display]);
 270  for I := 1 to Width[Value.Display] do
 271  begin
 272    if (Value.ValueQWord and 1) <> 0 then
 273      Result[Width[Value.Display] - I + 1] := '1';
 274    Value.ValueQWord := Value.ValueQWord shr 1;
 275  end;
 276end;
 277
 278function FormatSigned(Value: TJclSIMDValue): string;
 279const
 280  Width: array [pctBytes..pctQWords] of Byte = (4, 6, 11, 20);
 281begin
 282  if not (Value.Display in [pctBytes, pctWords, pctDWords, pctQWords]) then
 283    raise EJclExpertException.CreateRes(@RsEBadRegisterDisplay);
 284    
 285  case Value.Display of
 286    pctBytes:
 287      Result := IntToStr(Shortint(Value.ValueByte));
 288    pctWords:
 289      Result := IntToStr(Smallint(Value.ValueWord));
 290    pctDWords:
 291      Result := IntToStr(Integer(Value.ValueDWord));
 292    pctQWords:
 293      Result := IntToStr(Value.ValueQWord);
 294  else
 295    Result := '';
 296    Exit;
 297  end;
 298  Result := StringOfChar(' ', Width[Value.Display] - Length(Result)) + Result;
 299end;
 300
 301function FormatUnsigned(Value: TJclSIMDValue): string;
 302const
 303  Width: array [pctBytes..pctQWords] of Byte = (3, 5, 10, 20);
 304begin
 305  if not (Value.Display in [pctBytes, pctWords, pctDWords, pctQWords]) then
 306    raise EJclExpertException.CreateRes(@RsEBadRegisterDisplay);
 307    
 308  case Value.Display of
 309    pctBytes:
 310      Result := IntToStr(Byte(Value.ValueByte));
 311    pctWords:
 312      Result := IntToStr(Word(Value.ValueWord));
 313    pctDWords:
 314      Result := IntToStr(Cardinal(Value.ValueDWord));
 315    pctQWords:
 316      Result := IntToStr(Value.ValueQWord);
 317  else
 318    Result := '';
 319    Exit;
 320  end;
 321  Result := StringOfChar(' ', Width[Value.Display] - Length(Result)) + Result;
 322end;
 323
 324function FormatHexa(Value: TJclSIMDValue): string;
 325const
 326  Width: array [pctBytes..pctQWords] of Byte = (2, 4, 8, 16);
 327begin
 328  if not (Value.Display in [pctBytes, pctWords, pctDWords, pctQWords]) then
 329    raise EJclExpertException.CreateRes(@RsEBadRegisterDisplay);
 330    
 331  case Value.Display of
 332    pctBytes:
 333      Result := IntToHex(Value.ValueByte, Width[pctBytes]);
 334    pctWords:
 335      Result := IntToHex(Value.ValueWord, Width[pctWords]);
 336    pctDWords:
 337      Result := IntToHex(Value.ValueDWord, Width[pctDWords]);
 338    pctQWords:
 339      Result := IntToHex(Value.ValueQWord, Width[pctQWords]);
 340  else
 341    Result := '';
 342  end;
 343end;
 344
 345function FormatFloat(Value: TJclSIMDValue): string;
 346begin
 347  if not (Value.Display in [pctSingles, pctDoubles]) then
 348    raise EJclExpertException.CreateRes(@RsEBadRegisterDisplay);
 349    
 350  case Value.Display of
 351    pctSingles:
 352      Result := FloatToStr(Value.ValueSingle);
 353    pctDoubles:
 354      Result := FloatToStr(Value.ValueDouble);
 355  else
 356    Result := '';
 357  end;
 358  Result := StringOfChar(' ', 22 - Length(Result)) + Result; // 22 = max string length of a double value
 359end;
 360
 361function FormatValue(Value: TJclSIMDValue; Format: TJclSIMDFormat): string;
 362type
 363  TFormatFunction = function(Value: TJclSIMDValue): string;
 364var
 365  FormatFunction: TFormatFunction;
 366begin
 367  Result := '';
 368  case Format of
 369    sfBinary:
 370      FormatFunction := FormatBinary;
 371    sfSigned:
 372      FormatFunction := FormatSigned;
 373    sfUnsigned:
 374      FormatFunction := FormatUnsigned;
 375    sfHexa:
 376      FormatFunction := FormatHexa;
 377  else
 378    Exit;
 379  end;
 380  case Value.Display of
 381    pctBytes..pctQWords:
 382      Result := FormatFunction(Value);
 383    pctSingles..pctDoubles:
 384      Result := FormatFloat(Value);
 385  end;
 386end;
 387
 388function ParseBinary(StringValue: string; var Value: TJclSIMDValue): Boolean;
 389var
 390  TestValue: Int64;
 391  Index: Integer;
 392begin
 393  TestValue := 0;
 394  Result := False;
 395  if Length(StringValue) > 64 then
 396    Exit;
 397  for Index := 1 to Length(StringValue) do
 398  begin
 399    TestValue := TestValue shl 1;
 400    case StringValue[Index] of
 401      '0':
 402        ;
 403      '1':
 404        Inc(TestValue);
 405    else
 406      Exit;
 407    end;
 408  end;
 409  Result := True;
 410  case Value.Display of
 411    pctBytes:
 412      if (TestValue >= Byte($00)) and (TestValue <= Byte($FF)) then
 413        Value.ValueByte := TestValue
 414      else
 415        Result := False;
 416    pctWords:
 417      if (TestValue >= Word($0000)) and (TestValue <= Word($FFFF)) then
 418        Value.ValueWord := TestValue
 419      else
 420        Result := False;
 421    pctDWords:
 422      if (TestValue >= Cardinal($00000000)) and (TestValue <= Cardinal($FFFFFFFF)) then
 423        Value.ValueDWord := TestValue
 424      else
 425        Result := False;
 426    pctQWords:
 427      Value.ValueQWord := TestValue;
 428  else
 429    Result := False;
 430  end;
 431end;
 432
 433function ParseSigned(StringValue: string; var Value: TJclSIMDValue): Boolean;
 434var
 435  TestValue: Int64;
 436  ErrorCode: Integer;
 437begin
 438  Val(StringValue, TestValue, ErrorCode);
 439  Result := ErrorCode = 0;
 440  if Result then
 441    case Value.Display of
 442      pctBytes:
 443        if (TestValue >= Shortint($80)) and (TestValue <= Shortint($7F)) then
 444          Value.ValueByte := TestValue
 445        else
 446          Result := False;
 447      pctWords:
 448        if (TestValue >= Smallint($8000)) and (TestValue <= Smallint($7FFF)) then
 449          Value.ValueWord := TestValue
 450        else
 451          Result := False;
 452      pctDWords:
 453        if (TestValue >= Integer($80000000)) and (TestValue <= Integer($7FFFFFFF)) then
 454          Value.ValueDWord := TestValue
 455        else
 456          Result := False;
 457      pctQWords:
 458        Value.ValueQWord := TestValue;
 459    else
 460      Result := False;
 461    end;
 462end;
 463
 464function ParseUnsigned(StringValue: string; var Value: TJclSIMDValue): Boolean;
 465var
 466  TestValue: Int64;
 467  ErrorCode: Integer;
 468begin
 469  Val(StringValue, TestValue, ErrorCode);
 470  Result := ErrorCode = 0;
 471  if Result then
 472    case Value.Display of
 473      pctBytes:
 474        if (TestValue >= Byte($00)) and (TestValue <= Byte($FF)) then
 475          Value.ValueByte := TestValue
 476        else
 477          Result := False;
 478      pctWords:
 479        if (TestValue >= Word($0000)) and (TestValue <= Word($FFFF)) then
 480          Value.ValueWord := TestValue
 481        else
 482          Result := False;
 483      pctDWords:
 484        if (TestValue >= Cardinal($00000000)) and (TestValue <= Cardinal($FFFFFFFF)) then
 485          Value.ValueDWord := TestValue
 486        else
 487          Result := False;
 488      pctQWords:
 489        Value.ValueQWord := TestValue;
 490    else
 491      Result := False;
 492    end;
 493end;
 494
 495function ParseHexa(StringValue: string; var Value: TJclSIMDValue): Boolean;
 496var
 497  TestValue: Int64;
 498  Index: Integer;
 499begin
 500  TestValue := 0;
 501  Result := False;
 502  if Length(StringValue) > 16 then
 503    Exit;
 504  for Index := 1 to Length(StringValue) do
 505  begin
 506    TestValue := TestValue shl 4;
 507    case StringValue[Index] of
 508      '0':
 509        ;
 510      '1'..'9':
 511        Inc(TestValue, Ord(StringValue[Index]) - Ord('0'));
 512      'A'..'F':
 513        Inc(TestValue, Ord(StringValue[Index]) - Ord('A') + 10);
 514      'a'..'f':
 515        Inc(TestValue, Ord(StringValue[Index]) - Ord('a') + 10);
 516    else
 517      Exit;
 518    end;
 519  end;
 520  Result := True;
 521  case Value.Display of
 522    pctBytes:
 523      if (TestValue >= Byte($00)) and (TestValue <= Byte($FF)) then
 524        Value.ValueByte := TestValue
 525      else
 526        Result := False;
 527    pctWords:
 528      if (TestValue >= Word($0000)) and (TestValue <= Word($FFFF)) then
 529        Value.ValueWord := TestValue
 530      else
 531        Result := False;
 532    pctDWords:
 533      if (TestValue >= Cardinal($00000000)) and (TestValue <= Cardinal($FFFFFFFF)) then
 534        Value.ValueDWord := TestValue
 535      else
 536        Result := False;
 537    pctQWords:
 538      Value.ValueQWord := TestValue;
 539  else
 540    Result := False;
 541  end;
 542end;
 543
 544function ParseFloat(StringValue: string; var Value: TJclSIMDValue): Boolean;
 545var
 546  TestValue: Extended;
 547  ErrorCode: Integer;
 548begin
 549  if {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}DecimalSeparator <> '.' then
 550    StringValue := StringReplace(StringValue, {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}DecimalSeparator, '.', [rfReplaceAll, rfIgnoreCase]);
 551  Val(StringValue, TestValue, ErrorCode);
 552  Result := ErrorCode = 0;
 553  if Result then
 554    case Value.Display of
 555      pctSingles:
 556        if (TestValue >= -MaxSingle) and (TestValue <= MaxSingle) then
 557          Value.ValueSingle := TestValue
 558        else
 559          Result := False;
 560      pctDoubles:
 561        if (TestValue >= MaxDouble) and (TestValue <= MaxDouble) then
 562          Value.ValueDouble := TestValue
 563        else
 564          Result := False;
 565    else
 566      Result := False;
 567    end;
 568end;
 569
 570function ParseValue(const StringValue: string; var Value: TJclSIMDValue;
 571  Format: TJclSIMDFormat): Boolean;
 572type
 573  TParseFunction = function(StringValue: string; var Value: TJclSIMDValue): Boolean;
 574var
 575  ParseFunction: TParseFunction;
 576begin
 577  Result := False;
 578  case Format of
 579    sfBinary:
 580      ParseFunction := ParseBinary;
 581    sfSigned:
 582      ParseFunction := ParseSigned;
 583    sfUnsigned:
 584      ParseFunction := ParseUnsigned;
 585    sfHexa:
 586      ParseFunction := ParseHexa;
 587  else
 588    Exit;
 589  end;
 590  case Value.Display of
 591    pctBytes..pctQWords:
 592      Result := ParseFunction(StringValue, Value);
 593    pctSingles..pctDoubles:
 594      Result := ParseFloat(StringValue, Value);
 595  end;
 596end;
 597
 598function ReplaceSIMDRegisters(var Expression: string; Is64Bits, YMMEnabled: Boolean;
 599  var JclContext: TJclContext): Boolean;
 600var
 601  LocalString: string;
 602  RegisterPosition: Integer;
 603  DataPosition: Integer;
 604  DataType: string;
 605  Index: Integer;
 606  RegisterIndex: Integer;
 607  DataIndex: Integer;
 608  ErrorCode: Integer;
 609  NumberOfXMMRegister: Integer;
 610  AValue: TJclSIMDValue;
 611  ValueStr: string;
 612  OldLength: Integer;
 613  XMMMatch: Boolean;
 614begin
 615  if Is64Bits then
 616    NumberOfXMMRegister := 16
 617  else
 618    NumberOfXMMRegister := 8;
 619  Result := False;
 620  LocalString := AnsiUpperCase(Expression);
 621
 622  XMMMatch := False;
 623  RegisterPosition := AnsiPos('XMM', LocalString);
 624  if YMMEnabled and (RegisterPosition = 0) then
 625    RegisterPosition := AnsiPos('YMM', LocalString)
 626  else
 627    XMMMatch := True;
 628  while (RegisterPosition > 0) do
 629  begin
 630    for Index := RegisterPosition to Length(LocalString) do
 631      if LocalString[Index] = '.' then
 632        Break;
 633    if Index >= Length(LocalString) then
 634      Exit;
 635    Val(Copy(LocalString, RegisterPosition + 3, Index - RegisterPosition - 3), RegisterIndex, ErrorCode);
 636    if (ErrorCode <> 0) or (RegisterIndex < 0) or (RegisterIndex >= NumberOfXMMRegister) then
 637      Exit;
 638
 639    DataPosition := Index + 1;
 640    if DataPosition > Length(LocalString) then
 641      Exit;
 642    for Index := DataPosition to Length(LocalString) do
 643      if CharIsDigit(LocalString[Index]) then
 644        Break;
 645    if Index > Length(LocalString) then
 646      Exit;
 647    DataType := Copy(LocalString, DataPosition, Index - DataPosition);
 648
 649    DataPosition := Index;
 650    for Index := DataPosition to Length(LocalString) do
 651      if not CharIsDigit(LocalString[Index]) then
 652        Break;
 653    Val(Copy(LocalString, DataPosition, Index - DataPosition), DataIndex, ErrorCode);
 654    if (ErrorCode <> 0) or (DataIndex < 0) then
 655      Exit;
 656
 657    if CompareStr(DataType, 'BYTE') = 0 then
 658    begin
 659      AValue.Display := pctBytes;
 660      if DataIndex >= Low(JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].Bytes) then
 661      begin
 662        if XMMMatch then
 663          Exit;
 664        AValue.ValueByte := JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].Bytes[DataIndex];
 665      end
 666      else
 667        AValue.ValueByte := JclContext.ExtendedContext.SaveArea.XMMRegisters.LongXMM[RegisterIndex].Bytes[DataIndex];
 668    end
 669    else
 670    if CompareStr(DataType, 'WORD') = 0 then
 671    begin
 672      AValue.Display := pctWords;
 673      if DataIndex >= Low(JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].Words) then
 674      begin
 675        if XMMMatch then
 676          Exit;
 677        AValue.ValueWord := JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].Words[DataIndex];
 678      end
 679      else
 680        AValue.ValueWord := JclContext.ExtendedContext.SaveArea.XMMRegisters.LongXMM[RegisterIndex].Words[DataIndex];
 681    end
 682    else
 683    if CompareStr(DataType, 'DWORD') = 0 then
 684    begin
 685      AValue.Display := pctDWords;
 686      if DataIndex >= Low(JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].DWords) then
 687      begin
 688        if XMMMatch then
 689          Exit;
 690        AValue.ValueDWord := JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].DWords[DataIndex];
 691      end
 692      else
 693        AValue.ValueDWord := JclContext.ExtendedContext.SaveArea.XMMRegisters.LongXMM[RegisterIndex].DWords[DataIndex];
 694    end
 695    else
 696    if CompareStr(DataType, 'QWORD') = 0 then
 697    begin
 698      AValue.Display := pctQWords;
 699      if DataIndex >= Low(JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].QWords) then
 700      begin
 701        if XMMMatch then
 702          Exit;
 703        AValue.ValueQWord := JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].QWords[DataIndex];
 704      end
 705      else
 706        AValue.ValueQWord := JclContext.ExtendedContext.SaveArea.XMMRegisters.LongXMM[RegisterIndex].QWords[DataIndex];
 707    end
 708    else
 709    if CompareStr(DataType, 'SINGLE') = 0 then
 710    begin
 711      AValue.Display := pctSingles;
 712      if DataIndex >= Low(JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].Singles) then
 713      begin
 714        if XMMMatch then
 715          Exit;
 716        AValue.ValueSingle := JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].Singles[DataIndex];
 717      end
 718      else
 719        AValue.ValueSingle := JclContext.ExtendedContext.SaveArea.XMMRegisters.LongXMM[RegisterIndex].Singles[DataIndex];
 720    end
 721    else
 722    if CompareStr(DataType, 'DOUBLE') = 0 then
 723    begin
 724      AValue.Display := pctDoubles;
 725      if DataIndex >= Low(JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].Doubles) then
 726      begin
 727        if XMMMatch then
 728          Exit;
 729        AValue.ValueDouble := JclContext.ExtendedContext.ExtSaveArea2.LongYMM[RegisterIndex].Doubles[DataIndex];
 730      end
 731      else
 732        AValue.ValueDouble := JclContext.ExtendedContext.SaveArea.XMMRegisters.LongXMM[RegisterIndex].Doubles[DataIndex];
 733    end
 734    else
 735      Exit;
 736    ValueStr := Trim(FormatValue(AValue, sfSigned));
 737    if {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}DecimalSeparator <> '.' then
 738      ValueStr := StringReplace(ValueStr, {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}DecimalSeparator, '.', [rfReplaceAll, rfIgnoreCase]);
 739    if Length(ValueStr) >= Index - RegisterPosition then
 740    begin
 741      OldLength := Length(Expression);
 742      SetLength(Expression, Length(Expression) + Length(ValueStr) - (Index - RegisterPosition));
 743      if Length(ValueStr) > Index - RegisterPosition then
 744        Move(Expression[Index], Expression[RegisterPosition + Length(ValueStr)], OldLength - Index + 1);
 745      Move(ValueStr[1], Expression[RegisterPosition], Length(ValueStr));
 746    end
 747    else
 748    begin
 749      Move(ValueStr[1], Expression[RegisterPosition], Length(ValueStr));
 750      Move(Expression[Index], Expression[RegisterPosition + Length(ValueStr)], Length(Expression) - Index + 1);
 751      SetLength(Expression, Length(Expression) + Length(ValueStr) - (Index - RegisterPosition));
 752    end;
 753    LocalString := AnsiUpperCase(Expression);
 754    XMMMatch := False;
 755    RegisterPosition := AnsiPos('XMM', LocalString);
 756    if YMMEnabled and (RegisterPosition = 0) then
 757      RegisterPosition := AnsiPos('YMM', LocalString)
 758    else
 759      XMMMatch := True;
 760  end;
 761
 762  RegisterPosition := AnsiPos('MM', LocalString);
 763  while (RegisterPosition > 0) do
 764  begin
 765    for Index := RegisterPosition to Length(LocalString) do
 766      if LocalString[Index] = '.' then
 767        Break;
 768    if Index >= Length(LocalString) then
 769      Exit;
 770    Val(Copy(LocalString, RegisterPosition + 2, Index - RegisterPosition - 2), RegisterIndex, ErrorCode);
 771    if (ErrorCode <> 0) or (RegisterIndex < 0) or (RegisterIndex >= 8) then
 772      Exit;
 773
 774    DataPosition := Index + 1;
 775    if DataPosition > Length(LocalString) then
 776      Exit;
 777    for Index := DataPosition to Length(LocalString) do
 778      if CharIsDigit(LocalString[Index]) then
 779        Break;
 780    if Index > Length(LocalString) then
 781      Exit;
 782    DataType := Copy(LocalString, DataPosition, Index - DataPosition);
 783
 784    DataPosition := Index;
 785    for Index := DataPosition to Length(LocalString) do
 786      if not CharIsDigit(LocalString[Index]) then
 787        Break;
 788    Val(Copy(LocalString, DataPosition, Index - DataPosition), DataIndex, ErrorCode);
 789    if (ErrorCode <> 0) or (DataIndex < 0) then
 790      Exit;
 791
 792    if CompareStr(DataType, 'BYTE') = 0 then
 793    begin
 794      if DataIndex >= 8 then
 795        Exit;
 796      AValue.Display := pctBytes;
 797      AValue.ValueByte := JclContext.ExtendedContext.SaveArea.FPURegisters[RegisterIndex].Data.MMRegister.Bytes[DataIndex];
 798    end
 799    else
 800    if CompareStr(DataType, 'WORD') = 0 then
 801    begin
 802      if DataIndex >= 4 then
 803        Exit;
 804      AValue.Display := pctWords;
 805      AValue.ValueWord := JclContext.ExtendedContext.SaveArea.FPURegisters[RegisterIndex].Data.MMRegister.Words[DataIndex];
 806    end
 807    else
 808    if CompareStr(DataType, 'DWORD') = 0 then
 809    begin
 810      if DataIndex >= 2 then
 811        Exit;
 812      AValue.Display := pctDWords;
 813      AValue.ValueDWord := JclContext.ExtendedContext.SaveArea.FPURegisters[RegisterIndex].Data.MMRegister.DWords[DataIndex];
 814    end
 815    else
 816    if CompareStr(DataType, 'QWORD') = 0 then
 817    begin
 818      if DataIndex >= 1 then
 819        Exit;
 820      AValue.Display := pctQWords;
 821      AValue.ValueQWord := JclContext.ExtendedContext.SaveArea.FPURegisters[RegisterIndex].Data.MMRegister.QWords;
 822    end
 823    else
 824    if CompareStr(DataType, 'SINGLE') = 0 then
 825    begin
 826      if DataIndex >= 2 then
 827        Exit;
 828      AValue.Display := pctSingles;
 829      AValue.ValueSingle := JclContext.ExtendedContext.SaveArea.FPURegisters[RegisterIndex].Data.MMRegister.Singles[DataIndex];
 830    end
 831    else
 832      Exit;
 833    ValueStr := Trim(FormatValue(AValue, sfSigned));
 834    if {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}DecimalSeparator <> '.' then
 835      ValueStr := StringReplace(ValueStr, {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}DecimalSeparator, '.', [rfReplaceAll, rfIgnoreCase]);
 836    if Length(ValueStr) >= Index - RegisterPosition then
 837    begin
 838      OldLength := Length(Expression);
 839      SetLength(Expression, Length(Expression) + Length(ValueStr) - (Index - RegisterPosition));
 840      if Length(ValueStr) > Index - RegisterPosition then
 841        Move(Expression[Index], Expression[RegisterPosition + Length(ValueStr)], OldLength - Index + 1);
 842      Move(ValueStr[1], Expression[RegisterPosition], Length(ValueStr));
 843    end
 844    else
 845    begin
 846      Move(ValueStr[1], Expression[RegisterPosition], Length(ValueStr));
 847      Move(Expression[Index], Expression[RegisterPosition + Length(ValueStr)], Length(Expression) - Index + 1);
 848      SetLength(Expression, Length(Expression) + Length(ValueStr) - (Index - RegisterPosition));
 849    end;
 850    LocalString := AnsiUpperCase(Expression);
 851    RegisterPosition := AnsiPos('MM', LocalString);
 852  end;
 853
 854  Result := True;
 855end;
 856
 857// return the processor frame for the specified thread, this thread must be suspended
 858function GetThreadContext(hThread: THandle; lpContext: Pointer): BOOL; stdcall; external kernel32 name 'GetThreadContext';
 859
 860// set the processor frame for the specified thread, this thread must be suspended
 861function SetThreadContext(hThread: THandle; lpContext: Pointer): BOOL; stdcall; external kernel32 name 'SetThreadContext';
 862
 863function GetThreadJclContext(AThread: IOTAThread; out JclContext: TJclContext): Boolean;
 864var
 865  {$IFDEF COMPILER9_UP}
 866  OTAXMMRegs: TOTAXMMRegs;
 867  OTAThreadContext: TOTAThreadContext;
 868  {$ELSE ~COMPILER9_UP}
 869  ContextMemory: Pointer;
 870  AlignedContext: PJclContext;
 871  {$ENDIF ~COMPILER9_UP}
 872  ExtendedContextLength: DWORD;
 873  ExtendedContextMemory: Pointer;
 874  ExtendedContext: PCONTEXT_EX;
 875  LegacyContext: PContext;
 876  AVXContext: PJclExtSaveArea2;
 877begin
 878  // get YMM registers
 879  if oefAVX in GetOSEnabledFeatures then
 880  begin
 881    // allocate enough memory to get this extended context
 882    Result := GetExtendedContextLength(CONTEXT_XSTATE, @ExtendedContextLength);
 883    if Result then
 884    begin
 885      GetMem(ExtendedContextMemory, ExtendedContextLength);
 886      try
 887        Result := InitializeExtendedContext(ExtendedContextMemory, CONTEXT_XSTATE, ExtendedContext);
 888        if Result then
 889        begin
 890          // find usefull part locations in this extended context
 891          LegacyContext := LocateLegacyContext(ExtendedContext, nil);
 892          AVXContext := LocateExtendedFeature(ExtendedContext, XSTATE_GSSE, nil);
 893          // get the context
 894          Result := GetThreadContext(AThread.Handle, LegacyContext) and
 895            ((LegacyContext.ContextFlags and CONTEXT_XSTATE) <> 0);
 896          if Result then
 897            // copy the data
 898            JclContext.ExtendedContext.ExtSaveArea2 := AVXContext^
 899          else
 900            ResetMemory(JclContext.ExtendedContext.ExtSaveArea2, SizeOf(JclContext.ExtendedContext.ExtSaveArea2));
 901        end;
 902      finally
 903        FreeMem(ExtendedContextMemory);
 904      end;
 905    end;
 906  end
 907  else
 908  begin
 909    Result := True;
 910    ResetMemory(JclContext.ExtendedContext.ExtSaveArea2, SizeOf(JclContext.ExtendedContext.ExtSaveArea2));
 911  end;
 912  {$IFDEF COMPILER9_UP}
 913  // get XMM registers
 914  if Result then
 915    Result := AThread.GetOTAXMMRegisters(OTAXMMRegs);
 916  if Result then
 917  begin
 918    // get other registers
 919    JclContext.ExtendedContext.SaveArea.MXCSR := OTAXMMRegs.MXCSR;
 920    JclContext.ExtendedContext.SaveArea.MXCSRMask := $FFFFFFFF;
 921    Move(OTAXMMRegs,JclContext.ExtendedContext.SaveArea.XMMRegisters, SizeOf(TOTAXMMReg) * 8);
 922    OTAThreadContext := AThread.OTAThreadContext;
 923    JclContext.ExtendedContext.SaveArea.FCW := OTAThreadContext.FloatSave.ControlWord;
 924    JclContext.ExtendedContext.SaveArea.FSW := OTAThreadContext.FloatSave.StatusWord;
 925    JclContext.ExtendedContext.SaveArea.FTW := OTAThreadContext.FloatSave.TagWord;
 926    Move(OTAThreadContext.FloatSave.RegisterArea[00],JclContext.ExtendedContext.SaveArea.FPURegisters[0],SizeOf(Extended));
 927    Move(OTAThreadContext.FloatSave.RegisterArea[10],JclContext.ExtendedContext.SaveArea.FPURegisters[1],SizeOf(Extended));
 928    Move(OTAThreadContext.FloatSave.RegisterArea[20],JclContext.ExtendedContext.SaveArea.FPURegisters[2],SizeOf(Extended));
 929    Move(OTAThreadContext.FloatSave.RegisterArea[30],JclContext.ExtendedContext.SaveArea.FPURegisters[3],SizeOf(Extended));
 930    Move(OTAThreadContext.FloatSave.RegisterArea[40],JclContext.ExtendedContext.SaveArea.FPURegisters[4],SizeOf(Extended));
 931    Move(OTAThreadContext.FloatSave.RegisterArea[50],JclContext.ExtendedContext.SaveArea.FPURegisters[5],SizeOf(Extended));
 932    Move(OTAThreadContext.FloatSave.RegisterArea[60],JclContext.ExtendedContext.SaveArea.FPURegisters[6],SizeOf(Extended));
 933    Move(OTAThreadContext.FloatSave.RegisterArea[70],JclContext.ExtendedContext.SaveArea.FPURegisters[7],SizeOf(Extended));
 934  end;
 935  {$ELSE COMPILER9_UP}
 936  // get XMM registers
 937  if Result then
 938  begin
 939    GetMem(ContextMemory, SizeOf(TJclContext) + 15);
 940    try
 941      if (Cardinal(ContextMemory) and 15) <> 0 then
 942        AlignedContext := PJclContext((Cardinal(ContextMemory) + 16) and $FFFFFFF0)
 943      else
 944        AlignedContext := ContextMemory;
 945      AlignedContext^.ScalarContext.ContextFlags := CONTEXT_EXTENDED_REGISTERS;
 946      Result := GetThreadContext(AThread.Handle,AlignedContext) and
 947        ((AlignedContext^.ScalarContext.ContextFlags and CONTEXT_EXTENDED_REGISTERS)<>0);
 948      ResetMemory(AlignedContext.ExtendedContext.ExtSaveArea2, SizeOf(AlignedContext.ExtendedContext.ExtSaveArea2));
 949      if Result then
 950        JclContext := AlignedContext^
 951      else
 952        ResetMemory(JclContext, SizeOf(JclContext));
 953    finally
 954      FreeMem(ContextMemory);
 955    end;
 956  end;
 957  {$ENDIF COMPILER9_UP}
 958end;
 959
 960function SetThreadJclContext(AThread: IOTAThread; const JclContext: TJclContext): Boolean;
 961var
 962  {$IFDEF COMPILER9_UP}
 963  OTAXMMRegs: TOTAXMMRegs;
 964  {$ELSE ~COMPILER9_UP}
 965  ContextMemory: Pointer;
 966  AlignedContext: PJclContext;
 967  {$ENDIF ~COMPILER9_UP}
 968  ExtendedContextLength: DWORD;
 969  ExtendedContextMemory: Pointer;
 970  ExtendedContext: PCONTEXT_EX;
 971  LegacyContext: PContext;
 972  AVXContext: PJclExtSaveArea2;
 973begin
 974  // save YMM registers
 975  if oefAVX in GetOSEnabledFeatures then
 976  begin
 977    // allocate enough memory to get this extended context
 978    Result := GetExtendedContextLength(CONTEXT_XSTATE, @ExtendedContextLength);
 979    if Result then
 980    begin
 981      GetMem(ExtendedContextMemory, ExtendedContextLength);
 982      try
 983        Result := InitializeExtendedContext(ExtendedContextMemory, CONTEXT_XSTATE, ExtendedContext);
 984        if Result then
 985        begin
 986          // find usefull part locations in this extended context
 987          LegacyContext := LocateLegacyContext(ExtendedContext, nil);
 988          AVXContext := LocateExtendedFeature(ExtendedContext, XSTATE_GSSE, nil);
 989          // get the context
 990          Result := GetThreadContext(AThread.Handle, LegacyContext) and
 991            ((LegacyContext.ContextFlags and CONTEXT_XSTATE) <> 0);
 992          if Result then
 993          begin
 994            // copy the data
 995            AVXContext^ := JclContext.ExtendedContext.ExtSaveArea2;
 996            // set the context
 997            Result := SetThreadContext(AThread.Handle, LegacyContext);
 998          end;
 999        end;
1000      finally
1001        FreeMem(ExtendedContextMemory);
1002      end;
1003    end;
1004  end
1005  else
1006    Result := True;
1007  {$IFDEF COMPILER9_UP}
1008  if Result then
1009  begin
1010    try
1011      // save XMM registers
1012      OTAXMMRegs.MXCSR := JclContext.ExtendedContext.SaveArea.MXCSR;
1013      Move(JclContext.ExtendedContext.SaveArea.XMMRegisters,OTAXMMRegs,SizeOf(TOTAXMMReg) * 8);
1014      AThread.SetOTAXMMRegisters(OTAXMMRegs);
1015    except
1016      Result := False;
1017    end;
1018  end;
1019  {$ELSE ~COMPILER9_UP}
1020  if Result then
1021  begin
1022    GetMem(ContextMemory, SizeOf(TJclContext) + 15);
1023    try
1024      if (Cardinal(ContextMemory) and 15) <> 0 then
1025        AlignedContext := PJclContext((Cardinal(ContextMemory) + 16) and $FFFFFFF0)
1026      else
1027        AlignedContext := ContextMemory;
1028      AlignedContext^.ScalarContext.ContextFlags := CONTEXT_EXTENDED_REGISTERS;
1029      Result := GetThreadContext(AThread.Handle,AlignedContext) and
1030        ((AlignedContext^.ScalarContext.ContextFlags and CONTEXT_EXTENDED_REGISTERS) = CONTEXT_EXTENDED_REGISTERS);
1031      AlignedContext^ := JclContext;
1032      if Result then
1033        Result := SetThreadContext(AThread.Handle,AlignedContext);
1034      // TODO set the YMM registers
1035    finally
1036      FreeMem(ContextMemory);
1037    end;
1038  end;
1039  {$ENDIF COMPILER9_UP}
1040end;
1041
1042{$IFDEF UNITVERSIONING}
1043initialization
1044  RegisterUnitVersion(HInstance, UnitVersioning);
1045
1046finalization
1047  UnregisterUnitVersion(HInstance);
1048{$ENDIF UNITVERSIONING}
1049
1050end.