/jcl/experts/debug/simdview/JclSIMDUtils.pas
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.