1unit GDBMIDebugInstructions; 2 3{$mode objfpc}{$H+} 4 5interface 6 7uses 8 Classes, SysUtils, StrUtils, Math, 9 // LazUtils 10 LazLoggerBase, LazClasses, LazStringUtils, 11 // LazDebuggerGdbmi 12 CmdLineDebugger, GDBMIMiscClasses; 13 14type 15 16 { TGDBMICmdLineDebugger } 17 18 TGDBMICmdLineDebugger = class(TCmdLineDebugger) 19 protected 20 FErrorHandlingFlags: set of (ehfDeferReadWriteError, ehfGotReadError, ehfGotWriteError); 21 procedure DoReadError; override; 22 procedure DoWriteError; override; 23 end; 24 25 { TGDBInstruction } 26 27 TGDBInstructionFlag = ( 28 ifRequiresThread, 29 ifRequiresStackFrame, 30 ifRequiresMemLimit, 31 ifRequiresArrayLimit 32 ); 33 TGDBInstructionFlags = set of TGDBInstructionFlag; 34 35 TGDBInstructionResultFlag = ( 36 ifrComleted, 37 ifrFailed 38 ); 39 TGDBInstructionResultFlags = set of TGDBInstructionResultFlag; 40 41 TGDBInstructionErrorFlag = ( 42 ifeContentError, // the imput from gdb was not in the expected format 43 ifeWriteError, // writing to gdb (pipe) failed 44 ifeReadError, 45 ifeGdbNotRunning, 46 ifeTimedOut, 47 ifeRecoveredTimedOut, // not an error 48 ifeInvalidStackFrame, 49 ifeInvalidThreadId, 50 ifeQueueContextError // The thread or stack command went ok, but something else interfered with setting th econtext 51 ); 52 TGDBInstructionErrorFlags = set of TGDBInstructionErrorFlag; 53 54 TGDBInstructionQueue = class; 55 56 { TGDBInstruction } 57 58 TGDBInstruction = class(TRefCountedObject) 59 private 60 FArrayLenLimit: Integer; 61 FCommand: String; 62 FFlags: TGDBInstructionFlags; 63 FMemLimit: Integer; 64 FStackFrame: Integer; 65 FThreadId: Integer; 66 protected 67 FResultFlags: TGDBInstructionResultFlags; 68 FErrorFlags: TGDBInstructionErrorFlags; 69 FTimeOut: Integer; 70 procedure SendCommandDataToGDB(AQueue: TGDBInstructionQueue); virtual; 71 function ProcessInputFromGdb(const AData: String): Boolean; virtual; abstract; // True if data was handled 72 73 function GetTimeOutVerifier: TGDBInstruction; virtual; 74 procedure Init; virtual; 75 procedure InternalCreate(ACommand: String; 76 AThread, AFrame: Integer; // ifRequiresThread, ifRequiresStackFrame will always be included 77 AFlags: TGDBInstructionFlags; 78 ATimeOut: Integer 79 ); 80 public 81 constructor Create(ACommand: String; 82 AFlags: TGDBInstructionFlags = []; 83 ATimeOut: Integer = 0 84 ); 85 constructor Create(ACommand: String; 86 AThread: Integer; // ifRequiresThread will always be included 87 AOtherFlags: TGDBInstructionFlags = []; 88 ATimeOut: Integer = 0 89 ); 90 constructor Create(ACommand: String; 91 AThread, AFrame: Integer; // ifRequiresThread, ifRequiresStackFrame will always be included 92 AOtherFlags: TGDBInstructionFlags = []; 93 ATimeOut: Integer = 0 94 ); 95 procedure ApplyArrayLenLimit(ALimit: Integer); 96 procedure ApplyMemLimit(ALimit: Integer); 97 function IsSuccess: Boolean; 98 function IsCompleted: boolean; virtual; // No more InputFromGdb required 99 100 procedure MarkAsSuccess; 101 procedure HandleWriteError({%H-}ASender: TGDBInstruction); virtual; 102 procedure HandleReadError; virtual; 103 procedure HandleTimeOut; virtual; 104 procedure HandleRecoveredTimeOut; virtual; 105 procedure HandleNoGdbRunning; virtual; 106 procedure HandleContentError; virtual; 107 procedure HandleError(AnError: TGDBInstructionErrorFlag; AMarkAsFailed: Boolean = True); virtual; 108 function DebugText: String; 109 110 property Command: String read FCommand; 111 property ThreadId: Integer read FThreadId; 112 property StackFrame: Integer read FStackFrame; 113 property ArrayLenLimit: Integer read FArrayLenLimit; 114 property MemLimit: Integer read FMemLimit; 115 property Flags: TGDBInstructionFlags read FFlags; 116 property ResultFlags: TGDBInstructionResultFlags read FResultFlags; 117 property ErrorFlags: TGDBInstructionErrorFlags read FErrorFlags; 118 property TimeOut: Integer read FTimeOut; 119 end; 120 121 { TGDBInstructionVerifyTimeOut } 122 123 TGDBInstructionVerifyTimeOutState = ( 124 vtSent, vtError, 125 vtGotPrompt, 126 vtGotPrompt7, vtGotPrompt7gdb, vtGotPrompt7and7, vtGotPrompt7and7gdb, 127 vtGotPrompt1, vtGotPrompt1gdb, 128 vtGot7, vtGot7gdb, vtGot7and7, vtGot7and7gdb, vtGot1, vtGot1gdb 129 ); 130 131 TGDBInstructionVerifyTimeOut = class(TGDBInstruction) 132 private 133 FRunnigInstruction: TGDBInstruction; 134 FList: TGDBMINameValueList; 135 FPromptAfterErrorCount: Integer; 136 FVal7Data: String; 137 FState: TGDBInstructionVerifyTimeOutState; 138 protected 139 procedure SendCommandDataToGDB(AQueue: TGDBInstructionQueue); override; 140 function ProcessInputFromGdb(const AData: String): Boolean; override; 141 142 function GetTimeOutVerifier: TGDBInstruction; override; 143 function DebugText: String; 144 public 145 constructor Create(ARunnigInstruction: TGDBInstruction); 146 destructor Destroy; override; 147 148 procedure HandleWriteError(ASender: TGDBInstruction); override; 149 procedure HandleReadError; override; 150 procedure HandleTimeOut; override; 151 procedure HandleNoGdbRunning; override; 152 end; 153 154 { TGDBInstructionChangeMemLimit } 155 156 TGDBInstructionChangeMemLimit = class(TGDBInstruction) 157 private 158 FNewLimit: Integer; 159 FQueue: TGDBInstructionQueue; 160 //FDone: Boolean; 161 protected 162 procedure SendCommandDataToGDB(AQueue: TGDBInstructionQueue); override; 163 function ProcessInputFromGdb(const AData: String): Boolean; override; 164 function DebugText: String; 165 public 166 constructor Create(AQueue: TGDBInstructionQueue; ANewLimit: Integer); 167// procedure HandleError(AnError: TGDBInstructionErrorFlag; AMarkAsFailed: Boolean = True); override; 168 end; 169 170 { TGDBInstructionChangeArrayLimit } 171 172 TGDBInstructionChangeArrayLimit = class(TGDBInstruction) 173 private 174 FNewLimit: Integer; 175 FQueue: TGDBInstructionQueue; 176 //FDone: Boolean; 177 protected 178 procedure SendCommandDataToGDB(AQueue: TGDBInstructionQueue); override; 179 function ProcessInputFromGdb(const AData: String): Boolean; override; 180 function DebugText: String; 181 public 182 constructor Create(AQueue: TGDBInstructionQueue; ANewLimit: Integer); 183 184 procedure HandleError(AnError: TGDBInstructionErrorFlag; AMarkAsFailed: Boolean = True); 185 override; 186 end; 187 188 { TGDBInstructionChangeThread } 189 190 TGDBInstructionChangeThread = class(TGDBInstruction) 191 private 192 FSelThreadId: Integer; 193 FQueue: TGDBInstructionQueue; 194 FDone: Boolean; 195 protected 196 procedure SendCommandDataToGDB(AQueue: TGDBInstructionQueue); override; 197 function ProcessInputFromGdb(const AData: String): Boolean; override; 198 function DebugText: String; 199 public 200 constructor Create(AQueue: TGDBInstructionQueue; AThreadId: Integer); 201 202 procedure HandleError(AnError: TGDBInstructionErrorFlag; AMarkAsFailed: Boolean = True); 203 override; 204 end; 205 206 { TGDBInstructionChangeStackFrame } 207 208 TGDBInstructionChangeStackFrame = class(TGDBInstruction) 209 private 210 FSelStackFrame: Integer; 211 FQueue: TGDBInstructionQueue; 212 FDone: Boolean; 213 protected 214 procedure SendCommandDataToGDB(AQueue: TGDBInstructionQueue); override; 215 function ProcessInputFromGdb(const AData: String): Boolean; override; 216 function DebugText: String; 217 public 218 constructor Create(AQueue: TGDBInstructionQueue; AFrame: Integer); 219 procedure HandleError(AnError: TGDBInstructionErrorFlag; AMarkAsFailed: Boolean = True); 220 override; 221 end; 222 223 { TGDBInstructionQueue } 224 225 TGDBInstructionQueueFlag = ( 226 ifqValidThread, 227 ifqValidStackFrame 228 ); 229 TGDBInstructionQueueFlags = set of TGDBInstructionQueueFlag; 230 231 TGDBInstructionQueue = class 232 private 233 FCurrentInstruction: TGDBInstruction; 234 FCurrentStackFrame: Integer; 235 FCurrentThreadId: Integer; 236 FCurrentArrayLimit: Integer; 237 FCurrentMemLimit: Integer; 238 FExeCurInstructionStamp: Int64; 239 FDebugger: TGDBMICmdLineDebugger; 240 FFlags: TGDBInstructionQueueFlags; 241 242 procedure ExecuteCurrentInstruction; 243 procedure FinishCurrentInstruction; 244 procedure SetCurrentInstruction(AnInstruction: TGDBInstruction); 245 function HasCorrectThreadIdFor(AnInstruction: TGDBInstruction): Boolean; 246 function HasCorrectFrameFor(AnInstruction: TGDBInstruction): Boolean; 247 protected 248 function SendDataToGDB(ASender: TGDBInstruction; AData: String): Boolean; 249 function SendDataToGDB(ASender: TGDBInstruction; AData: String; const AValues: array of const): Boolean; 250 procedure HandleGdbDataBeforeInstruction(var {%H-}AData: String; var {%H-}SkipData: Boolean; 251 const {%H-}TheInstruction: TGDBInstruction); virtual; 252 procedure HandleGdbDataAfterInstruction(var {%H-}AData: String; const {%H-}Handled: Boolean; 253 const {%H-}TheInstruction: TGDBInstruction); virtual; 254 function GetSelectThreadInstruction(AThreadId: Integer): TGDBInstruction; virtual; 255 function GetSelectFrameInstruction(AFrame: Integer): TGDBInstruction; virtual; 256 257 property Debugger: TGDBMICmdLineDebugger read FDebugger; 258 public 259 constructor Create(ADebugger: TGDBMICmdLineDebugger); 260 procedure InvalidateThredAndFrame(AStackFrameOnly: Boolean = False); 261 procedure SetKnownThread(AThread: Integer); 262 procedure SetKnownThreadAndFrame(AThread, AFrame: Integer); 263 procedure RunInstruction(AnInstruction: TGDBInstruction); // Wait for instruction to be finished, not queuing 264 procedure ForceTimeOutAll(ATimeOut: Integer); 265 property CurrentThreadId: Integer read FCurrentThreadId; 266 property CurrentStackFrame: Integer read FCurrentStackFrame; 267 property Flags: TGDBInstructionQueueFlags read FFlags; 268 end; 269 270function dbgs(AState: TGDBInstructionVerifyTimeOutState): String; overload; 271function dbgs(AFlag: TGDBInstructionQueueFlag): String; overload; 272function dbgs(AFlags: TGDBInstructionQueueFlags): String; overload; 273function dbgs(AFlag: TGDBInstructionFlag): String; overload; 274function dbgs(AFlags: TGDBInstructionFlags): String; overload; 275 276implementation 277 278var 279 DBGMI_TIMEOUT_DEBUG, DBG_THREAD_AND_FRAME, DBG_VERBOSE: PLazLoggerLogGroup; 280 281const 282 TIMEOUT_AFTER_WRITE_ERROR = 50; 283 TIMEOUT_FOR_QUEUE_INSTR = 50; // select thread/frame 284 TIMEOUT_FOR_SYNC_AFTER_TIMEOUT = 2500; // extra timeout, while trying to recover from a suspected timeout 285 TIMEOUT_FOR_SYNC_AFTER_TIMEOUT_MAX = 3000; // upper limit, when using 2*original_timeout 286 287function dbgs(AState: TGDBInstructionVerifyTimeOutState): String; overload; 288begin 289 writestr(Result{%H-}, AState); 290end; 291 292function dbgs(AFlag: TGDBInstructionQueueFlag): String; 293begin 294 writestr(Result{%H-}, AFlag); 295end; 296 297function dbgs(AFlags: TGDBInstructionQueueFlags): String; 298var 299 i: TGDBInstructionQueueFlag; 300begin 301 Result := ''; 302 for i := low(TGDBInstructionQueueFlags) to high(TGDBInstructionQueueFlags) do 303 if i in AFlags then 304 if Result = '' then 305 Result := Result + dbgs(i) 306 else 307 Result := Result + ', ' +dbgs(i); 308 if Result <> '' then 309 Result := '[' + Result + ']'; 310end; 311 312function dbgs(AFlag: TGDBInstructionFlag): String; 313begin 314 writestr(Result{%H-}, AFlag); 315end; 316 317function dbgs(AFlags: TGDBInstructionFlags): String; 318var 319 i: TGDBInstructionFlag; 320begin 321 Result := ''; 322 for i := low(TGDBInstructionFlags) to high(TGDBInstructionFlags) do 323 if i in AFlags then 324 if Result = '' then 325 Result := Result + dbgs(i) 326 else 327 Result := Result + ', ' +dbgs(i); 328 if Result <> '' then 329 Result := '[' + Result + ']'; 330end; 331 332{ TGDBInstructionChangeMemLimit } 333 334procedure TGDBInstructionChangeMemLimit.SendCommandDataToGDB(AQueue: TGDBInstructionQueue); 335begin 336 if FNewLimit > 0 then 337 AQueue.SendDataToGDB(Self, 'set max-value-size %d', [FNewLimit]) 338 else 339 if FNewLimit = 0 then 340 AQueue.SendDataToGDB(Self, 'set max-value-size unlimited'); 341end; 342 343function TGDBInstructionChangeMemLimit.ProcessInputFromGdb(const AData: String): Boolean; 344begin 345 Result := False; 346 if (AData = '(gdb) ') then begin 347 Result := True; 348 MarkAsSuccess; 349 FQueue.FCurrentMemLimit := FNewLimit; 350 end 351 352 else 353 begin 354 debugln(DBG_VERBOSE, ['GDBMI TGDBInstructionChangeArrayLimit ignoring: ', AData]); 355 end; 356end; 357 358function TGDBInstructionChangeMemLimit.DebugText: String; 359begin 360 Result := ClassName; 361end; 362 363constructor TGDBInstructionChangeMemLimit.Create(AQueue: TGDBInstructionQueue; 364 ANewLimit: Integer); 365begin 366 inherited Create('', [], TIMEOUT_FOR_QUEUE_INSTR); 367 FQueue := AQueue; 368// FDone := False; 369 FNewLimit := ANewLimit; 370end; 371 372{ TGDBInstructionChangeArrayLimit } 373 374procedure TGDBInstructionChangeArrayLimit.SendCommandDataToGDB(AQueue: TGDBInstructionQueue); 375begin 376 AQueue.SendDataToGDB(Self, 'set print elements %d', [FNewLimit]); 377end; 378 379function TGDBInstructionChangeArrayLimit.ProcessInputFromGdb(const AData: String): Boolean; 380begin 381 Result := False; 382 if (AData = '(gdb) ') then begin 383 Result := True; 384 MarkAsSuccess; 385 FQueue.FCurrentArrayLimit := FNewLimit; 386 end 387 388 else 389 begin 390 debugln(DBG_VERBOSE, ['GDBMI TGDBInstructionChangeArrayLimit ignoring: ', AData]); 391 end; 392end; 393 394function TGDBInstructionChangeArrayLimit.DebugText: String; 395begin 396 Result := ClassName; 397end; 398 399constructor TGDBInstructionChangeArrayLimit.Create(AQueue: TGDBInstructionQueue; 400 ANewLimit: Integer); 401begin 402 inherited Create('', [], TIMEOUT_FOR_QUEUE_INSTR); 403 FQueue := AQueue; 404// FDone := False; 405 FNewLimit := ANewLimit; 406end; 407 408procedure TGDBInstructionChangeArrayLimit.HandleError(AnError: TGDBInstructionErrorFlag; 409 AMarkAsFailed: Boolean); 410begin 411 inherited HandleError(AnError, AMarkAsFailed); 412// FQueue.FCurrentArrayLimit := -2; 413 FQueue.FCurrentArrayLimit := FNewLimit; // ignore error 414end; 415 416{ TGDBMICmdLineDebugger } 417 418procedure TGDBMICmdLineDebugger.DoReadError; 419begin 420 include(FErrorHandlingFlags, ehfGotReadError); 421 if not(ehfDeferReadWriteError in FErrorHandlingFlags) 422 then inherited DoReadError; 423end; 424 425procedure TGDBMICmdLineDebugger.DoWriteError; 426begin 427 include(FErrorHandlingFlags, ehfGotWriteError); 428 if not(ehfDeferReadWriteError in FErrorHandlingFlags) 429 then inherited DoWriteError; 430end; 431 432{ TGDBInstruction } 433 434procedure TGDBInstruction.SendCommandDataToGDB(AQueue: TGDBInstructionQueue); 435begin 436 AQueue.SendDataToGDB(Self, FCommand); 437end; 438 439function TGDBInstruction.IsCompleted: boolean; 440begin 441 Result := FResultFlags * [ifrComleted, ifrFailed] <> []; 442end; 443 444procedure TGDBInstruction.MarkAsSuccess; 445begin 446 Include(FResultFlags, ifrComleted); 447end; 448 449procedure TGDBInstruction.HandleWriteError(ASender: TGDBInstruction); 450begin 451 HandleError(ifeWriteError, False); 452 if (FTimeOut = 0) or (FTimeOut > TIMEOUT_AFTER_WRITE_ERROR) then 453 FTimeOut := TIMEOUT_AFTER_WRITE_ERROR; 454end; 455 456procedure TGDBInstruction.HandleReadError; 457begin 458 HandleError(ifeReadError, True); 459end; 460 461procedure TGDBInstruction.HandleTimeOut; 462begin 463 HandleError(ifeTimedOut, True); 464end; 465 466procedure TGDBInstruction.HandleRecoveredTimeOut; 467begin 468 Include(FErrorFlags, ifeRecoveredTimedOut); 469end; 470 471procedure TGDBInstruction.HandleNoGdbRunning; 472begin 473 HandleError(ifeGdbNotRunning, True); 474end; 475 476procedure TGDBInstruction.HandleContentError; 477begin 478 HandleError(ifeContentError, True); 479end; 480 481procedure TGDBInstruction.HandleError(AnError: TGDBInstructionErrorFlag; 482 AMarkAsFailed: Boolean = True); 483begin 484 if AMarkAsFailed then 485 Include(FResultFlags, ifrFailed); 486 Include(FErrorFlags, AnError); 487end; 488 489function TGDBInstruction.GetTimeOutVerifier: TGDBInstruction; 490begin 491 if (ifeWriteError in ErrorFlags) then 492 Result := nil 493 else 494 Result := TGDBInstructionVerifyTimeOut.Create(Self); 495end; 496 497function TGDBInstruction.DebugText: String; 498begin 499 Result := ClassName + ': "' + FCommand + '", ' + dbgs(FFlags); 500 if ifRequiresThread in FFlags then 501 Result := Result + ' Thr=' + IntToStr(FThreadId); 502 if ifRequiresStackFrame in FFlags then 503 Result := Result + ' Frm=' + IntToStr(FStackFrame); 504end; 505 506procedure TGDBInstruction.Init; 507begin 508 // 509end; 510 511procedure TGDBInstruction.InternalCreate(ACommand: String; AThread, AFrame: Integer; 512 AFlags: TGDBInstructionFlags; ATimeOut: Integer); 513begin 514 FCommand := ACommand; 515 FThreadId := AThread; 516 FStackFrame := AFrame; 517 FFlags := AFlags; 518 FTimeOut := ATimeOut; 519end; 520 521constructor TGDBInstruction.Create(ACommand: String; AFlags: TGDBInstructionFlags; 522 ATimeOut: Integer = 0); 523begin 524 inherited Create; 525 InternalCreate(ACommand, -1, -1, AFlags, ATimeOut); 526 Init; 527end; 528 529constructor TGDBInstruction.Create(ACommand: String; AThread: Integer; 530 AOtherFlags: TGDBInstructionFlags; ATimeOut: Integer = 0); 531begin 532 inherited Create; 533 InternalCreate(ACommand, AThread, -1, 534 AOtherFlags + [ifRequiresThread], ATimeOut); 535 Init; 536end; 537 538constructor TGDBInstruction.Create(ACommand: String; AThread, AFrame: Integer; 539 AOtherFlags: TGDBInstructionFlags; ATimeOut: Integer = 0); 540begin 541 inherited Create; 542 InternalCreate(ACommand, AThread, AFrame, 543 AOtherFlags + [ifRequiresThread, ifRequiresStackFrame], ATimeOut); 544 Init; 545end; 546 547procedure TGDBInstruction.ApplyArrayLenLimit(ALimit: Integer); 548begin 549 FFlags := FFlags + [ifRequiresArrayLimit]; 550 FArrayLenLimit := ALimit; 551end; 552 553procedure TGDBInstruction.ApplyMemLimit(ALimit: Integer); 554begin 555 FFlags := FFlags + [ifRequiresMemLimit]; 556 FMemLimit := ALimit; 557end; 558 559function TGDBInstruction.IsSuccess: Boolean; 560begin 561 Result := ResultFlags * [ifrComleted, ifrFailed] = [ifrComleted] 562end; 563 564{ TGDBInstructionVerifyTimeOut } 565 566procedure TGDBInstructionVerifyTimeOut.SendCommandDataToGDB(AQueue: TGDBInstructionQueue); 567begin 568 AQueue.SendDataToGDB(Self, '-data-evaluate-expression 7'); 569 AQueue.SendDataToGDB(Self, '-data-evaluate-expression 1'); 570 FState := vtSent; 571end; 572 573function TGDBInstructionVerifyTimeOut.ProcessInputFromGdb(const AData: String): Boolean; 574type 575 TLineDataTipe = (ldOther, ldGdb, ldValue7, ldValue1); 576 577 function CheckData(const ALineData: String): TLineDataTipe; 578 begin 579 Result := ldOther; 580 if ALineData= '(gdb) ' then begin 581 Result := ldGdb; 582 exit; 583 end; 584 if LazStartsStr('^done,', AData) or (AData = '^done') then begin 585 if FList = nil then 586 FList := TGDBMINameValueList.Create(ALineData) 587 else 588 FList.Init(ALineData); 589 if FList.Values['value'] = '7' then 590 Result := ldValue7 591 else 592 if FList.Values['value'] = '1' then 593 Result := ldValue1 594 end; 595 end; 596 597 procedure SetError(APromptCount: Integer); 598 begin 599 FState := vtError; 600 FPromptAfterErrorCount := APromptCount; // prompt for val7 and val1 needed 601 FRunnigInstruction.HandleTimeOut; 602 if FPromptAfterErrorCount <= 0 then 603 FTimeOut := 50; // wait for timeout 604 end; 605 606begin 607 Result := True; 608 if FState = vtError then begin 609 dec(FPromptAfterErrorCount); 610 if FPromptAfterErrorCount <= 0 then 611 FTimeOut := 50; // wait for timeout 612 exit; 613 end; 614 615 case CheckData(AData) of 616 ldOther: begin 617 debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Got other data']); 618 Result := FRunnigInstruction.ProcessInputFromGdb(AData); 619 end; 620 ldGdb: 621 case FState of 622 vtSent: begin 623 debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Got prompt in order']); 624 FState := vtGotPrompt; 625 Result := FRunnigInstruction.ProcessInputFromGdb(AData); 626 if not FRunnigInstruction.IsCompleted then begin 627 debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Prompt was not accepted']); 628 SetError(2); // prompt for val=7 and val=1 needed 629 end; 630 end; 631 vtGotPrompt7: FState := vtGotPrompt7gdb; 632 vtGotPrompt7and7: FState := vtGotPrompt7and7gdb; 633 vtGotPrompt1: FState := vtGotPrompt1gdb; 634 vtGot7: FState := vtGot7gdb; 635 vtGot7and7: FState := vtGot7and7gdb; 636 vtGot1: FState := vtGot1gdb; 637 else begin 638 debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Extra Prompt ']); 639 if FState = vtGotPrompt 640 then SetError(1) // prompt val=1 needed 641 else SetError(0); // no more prompt needed 642 end; 643 end; 644 ldValue7: 645 case FState of 646 vtSent, vtGotPrompt: begin 647 debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Got value 7']); 648 FVal7Data := AData; 649 if FState = vtSent 650 then FState := vtGot7 651 else FState := vtGotPrompt7; 652 end; 653 vtGotPrompt7gdb, vtGot7gdb: begin 654 debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Got value 7 twice. Original Result?']); 655 Result := FRunnigInstruction.ProcessInputFromGdb(FVal7Data); 656 if FState = vtGotPrompt7gdb 657 then FState := vtGotPrompt7and7 658 else FState := vtGot7and7; 659 end; 660 else begin 661 debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Extra VAlue 7']); 662 if FState in [vtGotPrompt7, vtGot7] 663 then SetError(1) // prompt val=1 needed 664 else SetError(0); // no more prompt needed 665 end; 666 end; 667 ldValue1: 668 case FState of 669 vtSent: begin 670 debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Got other data']); 671 Result := FRunnigInstruction.ProcessInputFromGdb(AData); 672 end; 673 vtGotPrompt7gdb: FState := vtGotPrompt1; 674 vtGotPrompt7and7gdb: FState := vtGotPrompt1; 675 vtGot7gdb: FState := vtGot1; 676 vtGot7and7gdb: FState := vtGot1; 677 else begin 678 debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Wrong Value 1']); 679 SetError(0); 680 end; 681 end; 682 end; 683 684 if FState = vtGot1gdb then begin 685 // timeout, but recovored 686 debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Recovered']); 687 FRunnigInstruction.ProcessInputFromGdb('(gdb) '); // simulate prompt 688 FRunnigInstruction.HandleRecoveredTimeOut; 689 end; 690 if FState in [vtGot1gdb, vtGotPrompt1gdb] then begin 691 debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): All done: original Instruction completed=',dbgs(FRunnigInstruction.IsCompleted)]); 692 Include(FResultFlags, ifrComleted); 693 if not FRunnigInstruction.IsCompleted then 694 FRunnigInstruction.HandleTimeOut; 695 end; 696 697end; 698 699procedure TGDBInstructionVerifyTimeOut.HandleWriteError(ASender: TGDBInstruction); 700begin 701 inherited HandleWriteError(ASender); 702 FRunnigInstruction.HandleWriteError(ASender); 703end; 704 705procedure TGDBInstructionVerifyTimeOut.HandleReadError; 706begin 707 inherited HandleReadError; 708 FRunnigInstruction.HandleReadError; 709end; 710 711procedure TGDBInstructionVerifyTimeOut.HandleTimeOut; 712begin 713 inherited HandleTimeOut; 714 FRunnigInstruction.HandleTimeOut; 715end; 716 717procedure TGDBInstructionVerifyTimeOut.HandleNoGdbRunning; 718begin 719 inherited HandleNoGdbRunning; 720 FRunnigInstruction.HandleNoGdbRunning; 721end; 722 723function TGDBInstructionVerifyTimeOut.GetTimeOutVerifier: TGDBInstruction; 724begin 725 Result := nil; 726end; 727 728function TGDBInstructionVerifyTimeOut.DebugText: String; 729begin 730 Result := ClassName + ': for "' + FRunnigInstruction.DebugText; 731end; 732 733constructor TGDBInstructionVerifyTimeOut.Create(ARunnigInstruction: TGDBInstruction); 734var 735 t: Integer; 736begin 737 FRunnigInstruction := ARunnigInstruction; 738 FRunnigInstruction.AddReference; 739 t := FRunnigInstruction.TimeOut; 740 t := max(TIMEOUT_FOR_SYNC_AFTER_TIMEOUT, Min(TIMEOUT_FOR_SYNC_AFTER_TIMEOUT_MAX, t * 2)); 741 inherited Create('', FRunnigInstruction.ThreadId, FRunnigInstruction.StackFrame, 742 FRunnigInstruction.Flags * [ifRequiresThread, ifRequiresStackFrame], 743 t); 744end; 745 746destructor TGDBInstructionVerifyTimeOut.Destroy; 747begin 748 inherited Destroy; 749 FreeAndNil(FList); 750 if (FRunnigInstruction <> nil) then 751 FRunnigInstruction.ReleaseReference; 752end; 753 754{ TGDBInstructionChangeThread } 755 756procedure TGDBInstructionChangeThread.SendCommandDataToGDB(AQueue: TGDBInstructionQueue); 757begin 758 AQueue.SendDataToGDB(Self, '-thread-select %d', [FSelThreadId]); 759end; 760 761function TGDBInstructionChangeThread.ProcessInputFromGdb(const AData: String): Boolean; 762begin 763// "-thread-select 2" 764// "^done,new-thread-id="2",frame={level="0",addr="0x7707878f",func="ntdll!DbgUiConvertStateChangeStructure",args=[],from="C:\\Windows\\system32\\ntdll.dll"}" 765// "(gdb) " 766 767 Result := False; 768 if LazStartsStr('^done,', AData) or (AData = '^done') then begin 769 Result := True; 770 if FDone then 771 HandleContentError; 772 FDone := True; 773 end 774 775 else 776 if (AData = '(gdb) ') then begin 777 Result := True; 778 if not FDone then begin 779 HandleContentError; 780 end 781 else begin 782 MarkAsSuccess; 783 FQueue.FCurrentThreadId := FSelThreadId; 784 FQueue.FFlags := FQueue.FFlags + [ifqValidThread]; 785 end; 786 end 787 788 else 789 begin 790 debugln(DBG_VERBOSE, ['GDBMI TGDBInstructionChangeThread ignoring: ', AData]); 791 end; 792end; 793 794procedure TGDBInstructionChangeThread.HandleError(AnError: TGDBInstructionErrorFlag; 795 AMarkAsFailed: Boolean); 796begin 797 inherited HandleError(AnError, AMarkAsFailed); 798 FQueue.InvalidateThredAndFrame; 799end; 800 801function TGDBInstructionChangeThread.DebugText: String; 802begin 803 Result := ClassName; 804end; 805 806constructor TGDBInstructionChangeThread.Create(AQueue: TGDBInstructionQueue; 807 AThreadId: Integer); 808begin 809 inherited Create('', [], TIMEOUT_FOR_QUEUE_INSTR); 810 FQueue := AQueue; 811 FDone := False; 812 FSelThreadId := AThreadId; 813end; 814 815{ TGDBInstructionChangeStackFrame } 816 817procedure TGDBInstructionChangeStackFrame.SendCommandDataToGDB(AQueue: TGDBInstructionQueue); 818begin 819 AQueue.SendDataToGDB(Self, '-stack-select-frame %d', [FSelStackFrame]); 820end; 821 822function TGDBInstructionChangeStackFrame.ProcessInputFromGdb(const AData: String): Boolean; 823begin 824// "-stack-select-frame 0" 825// "^done" 826// "(gdb) " 827//OR ^error => keep selected ? 828 829 Result := False; 830 if LazStartsStr('^done,', AData) or (AData = '^done') then begin 831 Result := True; 832 if FDone then 833 HandleContentError; 834 FDone := True; 835 end 836 837 else 838 if (AData = '(gdb) ') then begin 839 Result := True; 840 if not FDone then begin 841 HandleContentError; 842 end 843 else begin 844 MarkAsSuccess; 845 FQueue.FCurrentStackFrame := FSelStackFrame; 846 FQueue.FFlags := FQueue.FFlags + [ifqValidStackFrame]; 847 end; 848 end 849 850 else 851 begin 852 debugln(DBG_VERBOSE, ['GDBMI TGDBInstructionChangeStackFrame ignoring: ', AData]); 853 end; 854end; 855 856procedure TGDBInstructionChangeStackFrame.HandleError(AnError: TGDBInstructionErrorFlag; 857 AMarkAsFailed: Boolean); 858begin 859 inherited HandleError(AnError, AMarkAsFailed); 860 FQueue.InvalidateThredAndFrame(True); 861end; 862 863function TGDBInstructionChangeStackFrame.DebugText: String; 864begin 865 Result := ClassName; 866end; 867 868constructor TGDBInstructionChangeStackFrame.Create(AQueue: TGDBInstructionQueue; 869 AFrame: Integer); 870begin 871 inherited Create('', [], TIMEOUT_FOR_QUEUE_INSTR); 872 FQueue := AQueue; 873 FDone := False; 874 FSelStackFrame := AFrame; 875end; 876 877{ TGDBInstructionQueue } 878 879procedure TGDBInstructionQueue.ExecuteCurrentInstruction; 880 function RunHelpInstruction(AnHelpInstr: TGDBInstruction): boolean; 881 begin 882 AnHelpInstr.AddReference; 883 try 884 FCurrentInstruction := AnHelpInstr; 885 FCurrentInstruction.SendCommandDataToGDB(Self); 886 FinishCurrentInstruction; 887 Result := AnHelpInstr.IsSuccess; 888 finally 889 AnHelpInstr.ReleaseReference; 890 end; 891 end; 892var 893 ExeInstr, HelpInstr: TGDBInstruction; 894 CurStamp: Int64; 895begin 896 if FCurrentInstruction = nil then 897 exit; 898 899 if FExeCurInstructionStamp = high(FExeCurInstructionStamp) then 900 FExeCurInstructionStamp := low(FExeCurInstructionStamp) 901 else 902 inc(FExeCurInstructionStamp); 903 904 ExeInstr := FCurrentInstruction; 905 ExeInstr.AddReference; 906 try 907 while true do begin 908 CurStamp := FExeCurInstructionStamp; 909 910 If (ifRequiresMemLimit in ExeInstr.Flags) and (FCurrentMemLimit <> ExeInstr.MemLimit) then begin 911 HelpInstr := TGDBInstructionChangeMemLimit.Create(Self, ExeInstr.MemLimit); 912 RunHelpInstruction(HelpInstr); // ignore result 913 end; 914 915 If (ifRequiresArrayLimit in ExeInstr.Flags) and (FCurrentArrayLimit <> ExeInstr.ArrayLenLimit) then begin 916 HelpInstr := TGDBInstructionChangeArrayLimit.Create(Self, ExeInstr.ArrayLenLimit); 917 RunHelpInstruction(HelpInstr); // ignore result 918 end; 919 920 if not HasCorrectThreadIdFor(ExeInstr) then begin 921 HelpInstr := GetSelectThreadInstruction(ExeInstr.ThreadId); 922 DebugLn(DBG_THREAD_AND_FRAME, ['TGDB_IQ: Changing Thread from: ', FCurrentThreadId, ' - ', dbgs(FFlags), 923 ' to ', ExeInstr.ThreadId, ' using [', HelpInstr.DebugText, '] for [', ExeInstr.DebugText, ']']); 924 if not RunHelpInstruction(HelpInstr) then begin 925 DebugLn(DBG_THREAD_AND_FRAME, ['TGDB_IQ: Changing Thread FAILED']); 926 ExeInstr.HandleError(ifeInvalidThreadId); 927 exit; 928 end 929 end; 930 931 if not HasCorrectThreadIdFor(ExeInstr) then begin 932 if CurStamp = FExeCurInstructionStamp then begin 933 DebugLn(DBG_THREAD_AND_FRAME, ['TGDB_IQ: Thread was interuppted, FAILING']); 934 ExeInstr.HandleError(ifeQueueContextError); 935 exit; 936 end; 937 938 DebugLn(DBG_THREAD_AND_FRAME, ['TGDB_IQ: Thread was interuppted, repeating']); 939 continue; 940 end; 941 942 943 if not HasCorrectFrameFor(ExeInstr) then begin 944 HelpInstr := GetSelectFrameInstruction(ExeInstr.StackFrame); 945 DebugLn(DBG_THREAD_AND_FRAME, ['TGDB_IQ: Changing Stack from: ', FCurrentStackFrame, ' - ', dbgs(FFlags), 946 ' to ', ExeInstr.StackFrame, ' using [', HelpInstr.DebugText, '] for [', ExeInstr.DebugText, ']']); 947 if not RunHelpInstruction(HelpInstr) then begin 948 DebugLn(DBG_THREAD_AND_FRAME, ['TGDB_IQ: Changing Stackframe FAILED']); 949 ExeInstr.HandleError(ifeInvalidStackFrame); 950 exit; 951 end; 952 end; 953 954 if not (HasCorrectThreadIdFor(ExeInstr) and HasCorrectFrameFor(ExeInstr)) then begin 955 if CurStamp = FExeCurInstructionStamp then begin 956 DebugLn(DBG_THREAD_AND_FRAME, ['TGDB_IQ: Stack was interuppted, FAILING']); 957 ExeInstr.HandleError(ifeQueueContextError); 958 exit; 959 end; 960 961 DebugLn(DBG_THREAD_AND_FRAME, ['TGDB_IQ: Stack was interuppted, repeating']); 962 continue; 963 end; 964 965 break; 966 end; // while true 967 finally 968 if (ExeInstr.RefCount > 1) and (not ExeInstr.IsCompleted) then 969 FCurrentInstruction := ExeInstr 970 else 971 FCurrentInstruction := nil; 972 ExeInstr.ReleaseReference; 973 end; 974 975 if FCurrentInstruction <> nil then 976 FCurrentInstruction.SendCommandDataToGDB(Self); 977end; 978 979procedure TGDBInstructionQueue.FinishCurrentInstruction; 980var 981 S: String; 982 NewInstr, ExeInstr: TGDBInstruction; 983 Skip: Boolean; 984 Handled: Boolean; 985begin 986 if FCurrentInstruction = nil then exit; 987 ExeInstr := FCurrentInstruction; 988 ExeInstr.AddReference; 989 try 990 while (FCurrentInstruction <> nil) and 991 (not FCurrentInstruction.IsCompleted) 992 do begin 993 if not FDebugger.DebugProcessRunning then begin 994 FCurrentInstruction.HandleNoGdbRunning; 995 break; 996 end; 997 998 S := FDebugger.ReadLine(FCurrentInstruction.TimeOut); 999 // Readline, may go into Application.ProcessMessages. 1000 // If it does, it has not (yet) read any data. 1001 // Therefore, if it does, another nested call to readline will work, and data will be returned in the correct order. 1002 // If a nested readline reads all data, then the outer will have nothing to return. 1003 1004 if (FCurrentInstruction = nil) or (FCurrentInstruction.IsCompleted) then begin 1005 if s <> '' then // Should not happen 1006 DebugLn(DBG_VERBOSE, ['TGDB_IQ: Got Data, but command was finished. Cmd: ', ExeInstr.DebugText, ' Data: ', S]); 1007 if not FDebugger.ReadLineWasAbortedByNested then 1008 DebugLn(DBG_VERBOSE, ['TGDB_IQ: Missing instruction. Not flagged as nested. Cmd: ', ExeInstr.DebugText, ' Data: ', S]); 1009 break; 1010 end; 1011 1012 if FDebugger.ReadLineWasAbortedByNested and (S = '') then 1013 Continue; 1014 1015 Skip := False; 1016 HandleGdbDataBeforeInstruction(S, Skip, FCurrentInstruction); 1017 // HandleGdbDataBeforeInstruction may execune other Instructions 1018 if (FCurrentInstruction = nil) or (FCurrentInstruction.IsCompleted) then 1019 break; 1020 1021 if (not Skip) and 1022 ( (not FDebugger.ReadLineTimedOut) or (S <> '') ) 1023 then 1024 Handled := FCurrentInstruction.ProcessInputFromGdb(S); 1025 1026 HandleGdbDataAfterInstruction(S, Handled, FCurrentInstruction); 1027 1028 if (ehfGotReadError in FDebugger.FErrorHandlingFlags) then begin 1029 FCurrentInstruction.HandleReadError; 1030 break; 1031 end; 1032 if FDebugger.ReadLineTimedOut then begin 1033 if FDebugger.IsInReset then 1034 break; 1035 NewInstr := FCurrentInstruction.GetTimeOutVerifier; 1036 if NewInstr <> nil then begin 1037 NewInstr.AddReference; 1038 ExeInstr.ReleaseReference; 1039 ExeInstr := NewInstr; 1040 // TODO: Run NewInstr; 1041 FCurrentInstruction := NewInstr; 1042 FCurrentInstruction.SendCommandDataToGDB(Self); // ExecuteCurrentInstruction; 1043 1044 end 1045 else begin 1046 FCurrentInstruction.HandleTimeOut; 1047 break; 1048 end; 1049 end; 1050 1051 end; // while 1052 FCurrentInstruction := nil; 1053 finally 1054 ExeInstr.ReleaseReference; 1055 end; 1056end; 1057 1058procedure TGDBInstructionQueue.SetCurrentInstruction(AnInstruction: TGDBInstruction); 1059begin 1060 FinishCurrentInstruction; 1061 FCurrentInstruction := AnInstruction; 1062end; 1063 1064function TGDBInstructionQueue.HasCorrectThreadIdFor(AnInstruction: TGDBInstruction): Boolean; 1065begin 1066 Result := not(ifRequiresThread in AnInstruction.Flags); 1067 if Result then 1068 exit; 1069 Result := (ifqValidThread in Flags) and (CurrentThreadId = AnInstruction.ThreadId); 1070end; 1071 1072function TGDBInstructionQueue.HasCorrectFrameFor(AnInstruction: TGDBInstruction): Boolean; 1073begin 1074 Result := not(ifRequiresStackFrame in AnInstruction.Flags); 1075 if Result then 1076 exit; 1077 Result := (ifqValidStackFrame in Flags) and (CurrentStackFrame = AnInstruction.StackFrame); 1078end; 1079 1080function TGDBInstructionQueue.SendDataToGDB(ASender: TGDBInstruction; AData: String): Boolean; 1081begin 1082 Result := True; 1083 FDebugger.FErrorHandlingFlags := FDebugger.FErrorHandlingFlags 1084 + [ehfDeferReadWriteError] - [ehfGotReadError, ehfGotWriteError]; 1085 1086 FDebugger.SendCmdLn(AData); 1087 1088 if ehfGotWriteError in FDebugger.FErrorHandlingFlags then begin 1089 Result := False; 1090// TODO try reading, but ensure timeout 1091 if FCurrentInstruction <> nil then 1092 FCurrentInstruction.HandleWriteError(ASender) 1093 else 1094 if ASender <> nil then 1095 ASender.HandleWriteError(ASender); 1096 end; 1097end; 1098 1099function TGDBInstructionQueue.SendDataToGDB(ASender: TGDBInstruction; AData: String; 1100 const AValues: array of const): Boolean; 1101begin 1102 Result := SendDataToGDB(ASender, Format(AData, AValues)); 1103end; 1104 1105procedure TGDBInstructionQueue.HandleGdbDataBeforeInstruction(var AData: String; 1106 var SkipData: Boolean; const TheInstruction: TGDBInstruction); 1107begin 1108 // 1109end; 1110 1111procedure TGDBInstructionQueue.HandleGdbDataAfterInstruction(var AData: String; 1112 const Handled: Boolean; const TheInstruction: TGDBInstruction); 1113begin 1114 // 1115end; 1116 1117function TGDBInstructionQueue.GetSelectThreadInstruction(AThreadId: Integer): TGDBInstruction; 1118begin 1119 Result := TGDBInstructionChangeThread.Create(Self, AThreadId); 1120end; 1121 1122function TGDBInstructionQueue.GetSelectFrameInstruction(AFrame: Integer): TGDBInstruction; 1123begin 1124 Result := TGDBInstructionChangeStackFrame.Create(Self, AFrame); 1125end; 1126 1127constructor TGDBInstructionQueue.Create(ADebugger: TGDBMICmdLineDebugger); 1128begin 1129 FDebugger := ADebugger; 1130end; 1131 1132procedure TGDBInstructionQueue.InvalidateThredAndFrame(AStackFrameOnly: Boolean = False); 1133begin 1134 if AStackFrameOnly then begin 1135 DebugLn(DBG_THREAD_AND_FRAME, ['TGDB_IQ: Invalidating queue''s stack only. Was: ', dbgs(FFlags), ' Thr=', FCurrentThreadId, ' Frm=', FCurrentStackFrame]); 1136 FFlags := FFlags - [ifqValidStackFrame]; 1137 end 1138 else begin 1139 DebugLn(DBG_THREAD_AND_FRAME, ['TGDB_IQ: Invalidating queue''s current thread and stack. Was: ', dbgs(FFlags), ' Thr=', FCurrentThreadId, ' Frm=', FCurrentStackFrame]); 1140 FFlags := FFlags - [ifqValidThread, ifqValidStackFrame]; 1141 end; 1142end; 1143 1144procedure TGDBInstructionQueue.SetKnownThread(AThread: Integer); 1145begin 1146 DebugLn(DBG_THREAD_AND_FRAME, ['TGDB_IQ: Setting queue''s current thread and stack. New: Thr=', AThread, ' Was: ', dbgs(FFlags), ' Thr=', FCurrentThreadId, ' Frm=', FCurrentStackFrame]); 1147 FCurrentThreadId := AThread; 1148 FFlags := FFlags + [ifqValidThread] - [ifqValidStackFrame]; 1149end; 1150 1151procedure TGDBInstructionQueue.SetKnownThreadAndFrame(AThread, AFrame: Integer); 1152begin 1153 DebugLn(DBG_THREAD_AND_FRAME, ['TGDB_IQ: Setting queue''s current thread and stack. New: Thr=', AThread, ' Frm=', AFrame,' Was: ', dbgs(FFlags), ' Thr=', FCurrentThreadId, ' Frm=', FCurrentStackFrame]); 1154 FCurrentThreadId := AThread; 1155 FCurrentStackFrame := AFrame; 1156 FFlags := FFlags + [ifqValidThread, ifqValidStackFrame]; 1157end; 1158 1159procedure TGDBInstructionQueue.RunInstruction(AnInstruction: TGDBInstruction); 1160begin 1161 SetCurrentInstruction(AnInstruction); 1162 ExecuteCurrentInstruction; 1163 FinishCurrentInstruction; 1164end; 1165 1166procedure TGDBInstructionQueue.ForceTimeOutAll(ATimeOut: Integer); 1167begin 1168 if FCurrentInstruction <> nil then 1169 FCurrentInstruction.FTimeOut := ATimeOut; 1170end; 1171 1172initialization 1173 DBGMI_TIMEOUT_DEBUG := DebugLogger.FindOrRegisterLogGroup('DBGMI_TIMEOUT_DEBUG' {$IFDEF DBGMI_TIMEOUT_DEBUG} , True {$ENDIF} ); 1174 DBG_THREAD_AND_FRAME := DebugLogger.FindOrRegisterLogGroup('DBG_THREAD_AND_FRAME' {$IFDEF DBG_THREAD_AND_FRAME} , True {$ENDIF} ); 1175 DBG_VERBOSE := DebugLogger.FindOrRegisterLogGroup('DBG_VERBOSE' {$IFDEF DBG_VERBOSE} , True {$ENDIF} ); 1176 1177end. 1178 1179