/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

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