Friday, November 04, 2011

Why no blogging? Alive and kicking :-)

As you may have noticed (or not :), this Blog has been silent since 2008. Several people have asked me recently why I'm not blogging anymore - here is a short explanation.

I was blogging quite actively for a while, but other priorities in my life (family, work, new house, exercising etc) have taken over. There is only so much time.

While I've been silent on the blog for a few years now, I'm still programming in Delphi professionally and I follow the community closely. At work, we have until now decided to stay with Delphi 2007, and I've been lagging behind on digging down into the low-level technical details of newest versions and features.

So there has been less to blog about. Now we're in the process of upgrading to XE2 - and there are regularly issues and points of interest that might spark my interest into blogging again - we'll see....

Also there are many, really good Delphi blogs now - I see less "holes" that needs to be discussed. If I blog, I don't want to blog about topics that others cover well, anyway :-).

Sunday, March 30, 2008

TDM#10: BorDebug – Return of the Giant

"The Delphi linker has always had the option of including so-called Turbo Debugger (TD32) debug information (on the Linker page of the Project Options dialog). The internal IDE Debugger does not normally use this information (Delphi 4 and 5 uses it when debugging external DLLs and EXE files), but instead relies on internal compiler structures build during an interactive compile.

External tools such as Borland’s Turbo Debugger[i] does rely on the TD32 information tacked at the end of the EXE or DLL file to enable symbolic debugging. This information is also used by a number of third party tools such as Numega’s BoundsChecker[ii], Turbo Power’s suite of Sleuth QA[iii] tools, Atanas Stoyanov’s freeware MemProof memory checking tool[iv], AutomatedQA’s QTime profiler[v], and Intel’s VTune sampling profiler [vi]

In this article we will see how we can utilise a relatively new DLL from Borland, BorDebug.DLL, to read and interpret the TD32 debug information in our own applications. [...]

We will discuss the functionality provided by the BorDebug DLL, present an import unit that gives us access to it from our Delphi applications, look at a set of wrapper classes to simplify the usage and show some simple demonstration programs."

H. Vassbotn, TDM, November 2000

unit HVBorDebug;
{
Simplified class interface for the BorDebug API
Written by Hallvard Vassbotn (hallvard.vassbotn@c2i.net),
April 1999 - September 2000

History:
15.04.99 HV Created
30.09.00 HV Updated and revised
}
interface

uses
Windows, Classes, TypInfo, BorDebug, SysUtils;

type
// ... removed a lot of stuff - see the code on disk
TBorDebug = class(TObject)
public
constructor Create(const aFilename: string = '');
destructor Destroy; override;
procedure Open;
procedure Close;
property Handle: TBorDebHandle read GetHandle;
property FileName: string;
property SkipNames: boolean;
property CacheNames: boolean;
property Active: boolean;
property NameCount: TItemCount;
property Names[Index: TNameIndex]: string;
property UnmangledNames[Index: TNameIndex]: string;
property RegisterName[RegIndex: TRegNameIndex]: string;
property SubSectionCount: TItemCount;
property SubSections[Index: TSubSectionIndex]: TBorDebugSubSection;
function CreateModule(const SubSection: TBorDebugSubSection): TBorDebugModule;
function CreateSrcModule(const SubSection: TBorDebugSubSection ): TBorDebugSrcModule;
procedure StartSymbols(const SubSection: TBorDebugSubSection);
function GetNextSymbol(var Symbol: TBorDebugSymbol): boolean;
function CreateSymbolInfo(const Symbol: TBorDebugSymbol): TSymbolInfo;
function CreateTypeInfo(const aType: TBorDebugType): TTypeInfo;
property TypeFromIndex[TypeIndex: TTypeIndex]: TBorDebugType;
property TypeFromOffset[Offset: TFileOffset]: TBorDebugType;
property TypeName[TypeIndex: TTypeIndex]: string;
property GlobalSymbols[const SubSection: TBorDebugSubSection]: TBorDebugGlobalSymbol;
property TypeCount: TItemCount;
property TypesSignature: TSignature;
property SubSectionDirectoryOffset: TFileOffset;
end;

TBorDebugModule = class(TBorDebugObject)
public
constructor Create(BorDebug: TBorDebug; Offset: TFileOffset);
destructor Destroy; override;
property Overlay : TOverlayIndex ;
property LibIndex : TLibraryIndex ;
property Style : TDebuggingStyle;
property TimeStamp : TBDTimeStamp ;
property SegmentCount : TItemCount ;
property NameIndex : TNameIndex ;
property Name : string ;
property ModuleSegmentList : TList ;
property Segments[Index: integer]: TModuleSegment;
end;

TBorDebugSrcModule = class(TBorDebugObject)
public
constructor Create(BorDebug: TBorDebug; Offset: TFileOffset);
destructor Destroy; override;
property RangeCount : TItemCount ;
property RangeSegments : PSegmentIndices;
property RangeSegmentStarts : PSegmentOffsets;
property RangeSegmentEnds : PSegmentOffsets;
property SourceCount : TItemCount ;
property SourceOffsets : PFileOffsets ;
property NameIndices : PNameIndices ;
property RangeCounts : PItemCounts ;
property SourceFileList : TList ;
property SourceFiles[Index: integer]: TSourceFileEntry;
property SourceNames[Index: integer]: string;
end;

TModuleSegment = class(TObject)
public
constructor Create(Module: TBorDebugModule; SegmentIndex: TSegmentIndex);
property LinkerSegment : TLinkerSegmentIndex;
property Offset : TFileOffset ;
property Size : TByteCount ;
property Flags : TSegmentFlags ;
end;

TSourceFileEntry = class(TObject)
public
constructor Create(SrcModule: TBorDebugSrcModule; SourceFileIndex: TSourceFileIndex);
destructor Destroy; override;
property BorDebug : TBorDebug ;
property Handle : TBorDebHandle ;
property Offset : TFileOffset ;
property SrcModule : TBorDebugSrcModule;
property Name : string ;
property NameIndex : TNameIndex ;
property SourceFileIndex : TSourceFileIndex;
property RangeSegments : PSegmentIndices ;
property RangeSegmentStarts : PSegmentOffsets ;
property RangeSegmentEnds : PSegmentOffsets ;
property LineNumberCounts : PItemCounts ;
property LineNumerOffsetList: TList ;
property RangeCount : TItemCount ;
property RangeLineNumbers[Index: integer]: TLineNumberOffsets;
end;

TLineNumberOffsets = class(TObject)
public
constructor Create(SourceFile: TSourceFileEntry; RangeIndex: TRangeIndex);
destructor Destroy; override;
property SourceFile : TSourceFileEntry;
property LineNumbers : PLineNumbers ;
property LineOffsets : PSegmentOffsets ;
property LineCount : TItemCount ;
property RangeIndex : TRangeIndex ;
end;

TSymbolInfo = class(TObject)
public
constructor Create(BorDebug: TBorDebug; Symbol: TBorDebugSymbol);
destructor Destroy; override;
function GetTypeIndex(var TypeIndex: TTypeIndex): boolean;
function GetNameIndex(var NameIndex: TNameIndex): boolean;
property Symbol : TBorDebugSymbol;
property SymbolOffset : TFileOffset ;
property Len : TByteCount ;
property Kind : TSymbolKind ;
property Info : TSymbolInfoRec ;
property KindAsString : string ;
end;

TTypeInfo = class(TObject)
public
constructor Create(BorDebug: TBorDebug; aType: TBorDebugType);
destructor Destroy; override;
property BDType : TBorDebugType ;
property TypeIndex : TTypeIndex ;
property TypeOffset : TFileOffset ;
property Length : TByteCount ;
property TypeKind : TTypeKind ;
property Info : TTypeInfoRec ;
property NameIndex : TNameIndex ;
property KindAsString : string ;
end;

As usual you can read the full article (PDF) and download the full, original code (zip). Enjoy! ;)




[i] Turbo Debugger, a free download: http://www.borland.com/bcppbuilder/turbodebugger/

[ii] Numega BoundsChecker for Delphi: http://www.numega.com/products/aed/del.shtml

[iii] Turbo Power Sleuth QA Suite: http://www.turbopower.com/products/sleuthqa/

[iv] Atanas Stoyanov’s MemProof home page: http://www.totalqa.com/downloads/memproof.asp

[v] QTime: http://www.totalqa.com/index.asp

[vi] VTune: http://developer.intel.com/vtune/

Saturday, March 15, 2008

TDM#9: Exceptional Stack Tracing (HVEST)

One of the key questions you should ask yourself as a serious Delphi developer is; what kind of exception handling and logging am I using. If you're not using any custom or third party solution for tracking down exceptional incidents that occur in your production systems or at your customer sites, you're missing out big time!

A proper exception handling and logging system should at least log the calling context (the calls that lead up to the exception) in the form of a stack trace. This makes it so much easier to track down, identify and fix the cause of the problem.

In 1999 I wrote such a tool and published it in The Delphi Magazine article Exceptional Stack Tracing in October 1999. As I have mentioned before, parts of this tool is based on my earlier work on 16-bit stack tracer, YAST. It also uses the excellent RTLI (run-time line information) tool by Vitaly Miryanov. At the time I was inspired by Per Larsen's ExHook32 and Stefan Hoffmeister's Debug Mapper. So I upgraded and improved the stack tracer for Win32, integrated the RTLI code and researched and developed a general implicit DLL import hooking system and a specific exception notification mechanism.

Putting all the pieces together we were able to get meaningful symbolic stack traces from any exceptional error incident - wether it happened during development, testing or at the customer's site. This made it an order of magnitude easier and faster to identify and fix bugs that caused the exception (or to handle it more gracefully).

I always spent a fair amount of time on my articles, but this one was by far the most time-consuming. Here are some key excerpts from the article.

"Often, during beta testing of an application (and, horrors, sometimes in a release version), users will encounter bugs in the form of exceptions (both logical such as EConvertError and hardware such as EAccessViolation). The tricky part is that only address of where the exception occurred is reported by the default Delphi exception handler. This is more often than not, less than helpful. Typically, that address will map to a line deep inside the VCL or RTL. What we’re really interested in is how we ended up there in the first place with invalid parameters (i.e. a blank string or a nil pointer). To get that we would need a complete stack trace of the calls that ended up in the exception being raised.

This article is about developing such an exception stack tracer. Not only will it show a complete stack trace leading up to an exception, but in the presence of so-called Run-Time Location Information (RTLI), it will also give a complete symbolic stack trace. "

"I remember reading an excellent article about PE files by Matt Pietrek[i]. In it he describes how implicit linking to external DLLs work. About the import address table, he says:

"Since the import address table is in a writeable section, it's relatively easy to intercept calls that an EXE or DLL makes to another DLL.. Simply patch the appropriate import address table entry to point at the desired interception function. There's no need to modify any code in either the caller or callee images. What could be easier?"

Yeah, what could be easier <g>? Such a statement just screams: “Implement me!”. We will implement a completely general way of hooking any routine in any implicitly loaded DLL. We can then use this technique to hook the Kernel32.RaiseException routine that is called from System._RaiseExcept. "

The key routine for hooking DLL imports is listed below:

function IsWin95CallThunk(Thunk: PWin95CallThunk): boolean;
begin
Result := (Thunk^.PUSH = $68) and (Thunk^.JMP = $E9);
end;

function ReplaceImport(Base: Pointer; ModuleName: PChar; FromProc, ToProc: pointer): boolean;
var
NtHeader : PImageNtHeaders;
ImportDescriptor : PImageImportDescriptor;
ImportEntry : PImageThunkData;
CurrModuleName : PChar;
IsThunked : Boolean;
FromProcThunk : PWin95CallThunk;
ImportThunk : PWin95CallThunk;
FoundProc : boolean;
begin
Result := false;
FromProcThunk := PWin95CallThunk(FromProc);
IsThunked := (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and
IsWin95CallThunk(FromProcThunk);
NtHeader := GetImageNtHeader(Base);
ImportDescriptor := PImageImportDescriptor(DWORD(Base)+
NtHeader.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress);
while ImportDescriptor^.NameOffset <> 0 do
begin
CurrModuleName := PChar(Base) + ImportDescriptor^.NameOffset;
if StrIComp(CurrModuleName, ModuleName) = 0 then
begin
ImportEntry := PImageThunkData(DWORD(Base) + ImportDescriptor^.IATOffset);
while ImportEntry^.FunctionPtr <> nil do
begin
if IsThunked then
begin
ImportThunk := PWin95CallThunk(ImportEntry^.FunctionPtr);
FoundProc := IsWin95CallThunk(ImportThunk) and
(ImportThunk^.Addr = FromProcThunk^.Addr);
end
else
FoundProc := (ImportEntry^.FunctionPtr = FromProc);
if FoundProc then
begin
ImportEntry^.FunctionPtr := ToProc;
Result := true;
end;
Inc(ImportEntry);
end;
end;
Inc(ImportDescriptor);
end;
end;


"Hooking RaiseException


Now that we have the HVHookDLL, it is very easy to hook the RaiseException routine in Kernel32.DLL – take a look at [the code below]"

unit HVExceptNotify;
// Unit that provides a notification service when exceptions are being raised
//
// Written by Hallvard Vassbotn, hallvard@balder.no, September 1999
interface

type
TExceptNotify = procedure (ExceptObj: TObject; ExceptAddr: pointer; OSException: boolean);
var
ExceptNotify: TExceptNotify;

implementation

uses
Windows,
SysUtils,
HVHookDLL;

var
Kernel32_RaiseException : procedure (dwExceptionCode, dwExceptionFlags, nNumberOfArguments: DWORD;
lpArguments: PDWORD); stdcall;

type
PExceptionArguments = ^TExceptionArguments;
TExceptionArguments = record
ExceptAddr: pointer;
ExceptObj : TObject;
end;

procedure HookedRaiseException(ExceptionCode, ExceptionFlags, NumberOfArguments: DWORD;
Arguments: PExceptionArguments); stdcall;
// All calls to Kernel32.RaiseException ends up here
const
// D2 has a different signature for Delphi exceptions
cDelphiException = {$IFDEF VER90}$0EEDFACE{$ELSE}$0EEDFADE{$ENDIF};
cNonContinuable = 1;
begin
// We're only interested in Delphi exceptions raised from System's
// internal _RaiseExcept routine
if (ExceptionFlags = cNonContinuable) and
(ExceptionCode = cDelphiException) and
(NumberOfArguments = 7) and
(DWORD(Arguments) = DWORD(@Arguments) + 4) then
begin
// Run the event if it has been assigned
if Assigned(ExceptNotify) then
ExceptNotify(Arguments.ExceptObj, Arguments.ExceptAddr, false);
end;
// Call the original routine in Kernel32.DLL
Kernel32_RaiseException(ExceptionCode, ExceptionFlags, NumberOfArguments, PDWORD(Arguments));
end;

var
SysUtils_ExceptObjProc: function (P: PExceptionRecord): Exception;

function HookedExceptObjProc(P: PExceptionRecord): Exception;
begin
// Non-Delphi exceptions such as AVs, OS and hardware exceptions
// end up here. This routine is normally responsible for creating
// a Delphi Exception object corresponding to the OS-level exception
// described in the TExceptionRecord structure.
//
// We leave the mapping to the standard SysUtils routine,
// but hook this to know about the exception and call our
// event.

// First call the original mapping function in SysUtils
Result := SysUtils_ExceptObjProc(P);

// Run the event if it has been assigned
if Assigned(ExceptNotify) then
ExceptNotify(Result, P^.ExceptionAddress, true);
end;

function GetRaiseExceptAddr: pointer;
asm
LEA EAX, System.@RaiseExcept;
end;

initialization
SysUtils_ExceptObjProc := System.ExceptObjProc;
System.ExceptObjProc := @HookedExceptObjProc;
HookImport(Pointer(FindHInstance(GetRaiseExceptAddr)), 'Kernel32.dll', 'RaiseException', @HookedRaiseException, @Kernel32_RaiseException)

finalization
UnHookImport(Pointer(FindHInstance(GetRaiseExceptAddr)), 'Kernel32.dll', 'RaiseException', @HookedRaiseException, @Kernel32_RaiseException);
System.ExceptObjProc := @SysUtils_ExceptObjProc;
SysUtils_ExceptObjProc := nil;

end.


"The definition of what might be useful context information can vary according to what kind of application you are developing. The name of the currently focused form, the name of active database tables, the name of the logged in user and other global information might be useful. You can easily add any such value-added information yourself.

However, in all cases, a complete overview of the function calls that preceded the raised exception will be most useful. To get that, we have to implement something called a stack tracer. A stack tracer will analyze the current contents of the stack and try to figure out the return addresses stored there by the CPU as part of the CALL instruction operation.

YAST Nostalgia


[...] I have now converted [the 16-bit YAST stack tracer] to a 32-bit version and added some bells and whistles along the way – see the [code below]"

unit HVYAST32;
// Yet-Another-Stack-Tracer, 32-bit version
//
// Loosely based on my 16-bit YAST code published in
// The Delphi Magazine, issue 7.
//
// Description: A general call-back based stack-trace utility.
// Both stack frames based and raw stack tracing is supported.
//
// Written by Hallvard Vassbotn, hallvard@balder.no, July 1999
//
interface

uses
Windows,
SysUtils;

// The generic stack tracing machinery

const
MaxBlock = MaxInt-$f;
type
PBytes = ^TBytes;
TBytes = array[0..MaxBlock div SizeOf(byte)] of byte;
PDWORDS = ^TDWORDS;
TDWORDS = array[0..MaxBlock div SizeOf(DWORD)] of DWORD;
PStackFrame = ^TStackFrame;
TStackFrame = record
CallersEBP : DWORD;
CallerAdr : DWORD;
end;
TStackInfo = record
CallerAdr : DWORD;
Level : DWORD;
CallersEBP : DWORD;
DumpSize : DWORD;
ParamSize : DWORD;
ParamPtr : PDWORDS;
case integer of
0 : (StackFrame : PStackFrame);
1 : (DumpPtr : PBytes);
end;
TReportStackFrame = function(var StackInfo: TStackInfo; PrivateData: Pointer): boolean;

procedure TraceStackFrames(ReportStackFrame: TReportStackFrame; PrivateData: Pointer);
procedure TraceStackRaw(ReportStackFrame: TReportStackFrame; PrivateData: Pointer);

// Default stack tracer

const
MaxStackLevels = 50;
type
TStackInfoArray = array[0..MaxStackLevels-1] of TStackInfo;
var
StackDump: TStackInfoArray;
StackDumpCount: integer;

function PhysicalToLogical(Physical: DWORD): DWORD;
function DefaultReportStackFrame(var StackInfo: TStackInfo; PrivateData: Pointer): boolean;
procedure SaveStackTrace(Raw: boolean; IgnoreLevels: integer; FirstCaller: pointer);

implementation

uses
HVPEUtils;

{$W-} // This routine should not have a EBP stack frame
function GetEBP: pointer;
// Return the current contents of the EBP register
asm
MOV EAX, EBP
end;

function GetESP: pointer;
// Return the current contents of the ESP register
asm
MOV EAX, ESP
end;

function GetStackTop: DWORD;
asm
// Pick up the top of the stack from the Thread Information Block (TIB)
// pointed to by the FS segment register.
//
// Reference: Matt Pietrek, MSJ, Under the hood, on TIBs:
// PVOID pvStackUserTop // 04h Top of user stack
// http:{msdn.microsoft.com/library/periodic/period96/periodic/msj/F1/D6/S2CE.htm }
//
MOV EAX, FS:[4]
end;

var
TopOfStack : DWORD;
BaseOfStack: DWORD;
BaseOfCode : DWORD;
TopOfCode : DWORD;

procedure InitGlobalVars;
var
NTHeader: PImageNTHeaders;
begin
{ Get pointers into the EXE file image }
if BaseOfCode = 0 then
begin
NTHeader := GetImageNtHeader(Pointer(hInstance));
BaseOfCode := DWord(hInstance) + NTHeader.OptionalHeader.BaseOfCode;
TopOfCode := BaseOfCode + NTHeader.OptionalHeader.SizeOfCode;
TopOfStack := GetStackTop;
end;
end;

function ValidStackAddr(StackAddr: DWORD): boolean;
begin
Result := (BaseOfStack < StackAddr) and (StackAddr < TopOfStack);
end;

function ValidCodeAddr(CodeAddr: DWORD): boolean;
begin
Result := (BaseOfCode < CodeAddr) and (CodeAddr < TopOfCode);
end;

function ValidCallSite(CodeAddr: DWORD): boolean;
// Validate that the code address is a valid code site
//
// Information from Intel Manual 24319102(2).pdf, Download the 6.5 MBs from:
// http://developer.intel.com/design/pentiumii/manuals/243191.htm
// Instruction format, Chapter 2 and The CALL instruction: page 3-53, 3-54
var
CodeDWORD4: DWORD;
CodeDWORD8: DWORD;
begin
// First check that the address is within range of our code segment!
Result := (BaseOfCode < CodeAddr) and (CodeAddr < TopOfCode);

// Now check to see if the instruction preceding the return address
// could be a valid CALL instruction
if Result then
begin
// Check the instruction prior to the potential call site.
// We consider it a valid call site if we find a CALL instruction there
// Check the most common CALL variants first
CodeDWORD8 := PDWORD(CodeAddr-8)^;
CodeDWORD4 := PDWORD(CodeAddr-4)^;

Result :=
((CodeDWORD8 and $FF000000) = $E8000000) // 5-byte, CALL [-$1234567]
or ((CodeDWORD4 and $38FF0000) = $10FF0000) // 2 byte, CALL EAX
or ((CodeDWORD4 and $0038FF00) = $0010FF00) // 3 byte, CALL [EBP+0x8]
or ((CodeDWORD4 and $000038FF) = $000010FF) // 4 byte, CALL ??
or ((CodeDWORD8 and $38FF0000) = $10FF0000) // 6-byte, CALL ??
or ((CodeDWORD8 and $0038FF00) = $0010FF00) // 7-byte, CALL [ESP-0x1234567]
// It is possible to simulate a CALL by doing a PUSH followed by RET,
// so we check for a RET just prior to the return address
or ((CodeDWORD4 and $FF000000) = $C3000000);// PUSH XX, RET

// Because we're not doing a complete disassembly, we will potentially report
// false positives. If there is odd code that uses the CALL 16:32 format, we
// can also get false negatives.

end;
end;

function NextStackFrame(var StackFrame: PStackFrame;
var StackInfo : TStackInfo): boolean;
begin
// Only report this stack frame into the StackInfo structure
// if the StackFrame pointer, EBP on the stack and return
// address on the stack are valid addresses
while ValidStackAddr(DWORD(StackFrame)) do
begin
// CallerAdr within current process space, code segment etc.
if ValidCodeAddr(StackFrame^.CallerAdr) then
begin
Inc(StackInfo.Level);
StackInfo.StackFrame := StackFrame;
StackInfo.ParamPtr := PDWORDS(DWORD(StackFrame) + SizeOf(TStackFrame));
StackInfo.CallersEBP := StackFrame^.CallersEBP;
StackInfo.CallerAdr := StackFrame^.CallerAdr;
StackInfo.DumpSize := StackFrame^.CallersEBP - DWORD(StackFrame);
StackInfo.ParamSize := (StackInfo.DumpSize - SizeOf(TStackFrame)) div 4;
// Step to the next stack frame by following the EBP pointer
StackFrame := PStackFrame(StackFrame^.CallersEBP);
Result := true;
Exit;
end;
// Step to the next stack frame by following the EBP pointer
StackFrame := PStackFrame(StackFrame^.CallersEBP);
end;
Result := false;
end;

{$W+} // We must have stack-frames on for this routine

procedure TraceStackFrames(ReportStackFrame: TReportStackFrame; PrivateData: Pointer);
var
StackFrame : PStackFrame;
StackInfo : TStackInfo;
begin
// Start at level 0
StackInfo.Level := 0;

// Make sure the global variables are correctly set
InitGlobalVars;

// Get the current stack from from the EBP register
StackFrame := GetEBP;

// We define the bottom of the valid stack to be the current EBP Pointer
// There is a TIB field called pvStackUserBase, but this includes more of the
// stack than what would define valid stack frames.
BaseOfStack := DWORD(StackFrame) - 1;

// Loop over and report all valid stackframes
while NextStackFrame(StackFrame, StackInfo) and
ReportStackFrame(StackInfo, PrivateData) do
{Loop};
end;

procedure TraceStackRaw(ReportStackFrame: TReportStackFrame; PrivateData: Pointer);
var
StackInfo : TStackInfo;
StackPtr : PDWORD;
PrevCaller: DWORD;
begin
// We define the bottom of the valid stack to be the current ESP pointer
BaseOfStack := DWORD(GetESP);

// We will not be able to fill in all the fields in the StackInfo record,
// so just blank it all out first
FillChar(StackInfo, SizeOf(StackInfo), 0);

// Make sure the global variables are correctly set
InitGlobalVars;

// Clear the previous call address
PrevCaller := 0;

// Get a pointer to the current bottom of the stack
StackPtr := PDWORD(BaseOfStack);

// Loop through all of the valid stack space
while DWORD(StackPtr) < TopOfStack do
begin

// If the current DWORD on the stack,
// refers to a valid call site...
if ValidCallSite(StackPtr^) and (StackPtr^ <> PrevCaller) then
begin
// then pick up the callers address
StackInfo.CallerAdr := StackPtr^;

// remeber to callers address so that we don't report it repeatedly
PrevCaller := StackPtr^;

// increase the stack level
Inc(StackInfo.Level);

// then report it back to our caller
if not ReportStackFrame(StackInfo, PrivateData) then
Break;
end;

// Look at the next DWORD on the stack
Inc(StackPtr);
end;
end;

function DefaultReportStackFrame(var StackInfo: TStackInfo; PrivateData: Pointer): boolean;
begin
Result := (StackDumpCount < MaxStackLevels-1);
if Result and // We have an available slot
(DWORD(PrivateData) < StackInfo.Level) then // We're not going to skip this level
begin
// Save the contents of this stack frame
StackDump[StackDumpCount] := StackInfo;
Inc(StackDumpCount);
end;
end;

procedure SaveStackTrace(Raw: boolean; IgnoreLevels: integer; FirstCaller: pointer);
begin
FillChar(StackDump, SizeOf(StackDump), 0);
StackDumpCount := 0;
// Fill the first slot, if we are given an address directly
if Assigned(FirstCaller) then
begin
StackDump[0].CallerAdr := DWORD(FirstCaller);
StackDumpCount := 1;
end;
if Raw
then TraceStackRaw (DefaultReportStackFrame, Pointer(IgnoreLevels))
else TraceStackFrames(DefaultReportStackFrame, Pointer(IgnoreLevels));
end;

const
LinkerOffset = $1000;

function PhysicalToLogical(Physical: DWORD): DWORD;
begin
Result := Physical
- DWORD(HInstance)
- LinkerOffset;
end;

end.


"To Stack Frame, or not to Stack Frame – that is the Question


There are generally two different types of algorithms to choose from when implementing a stack tracer: the more elegant stack frame based algorithm and the raw brute force algorithm.


[...]


The frame-based stack tracing is elegant and fairly fast, but it has one major weakness. It will not find callers that have no stack frames. With the current crop of optimising compilers, most smaller routines will not have stack frames and this reduces the usefulness of the stack tracer dramatically. There are two solutions to this. Either force stack frames for all your code – and preferably the VCL and RTL, too. Or use another algorithm.


[...]


[T]he brute-force method is much more primitive. The algorithm is very easy: just look at all the DWORDs stored on the stack. If a DWORD happens to be a value that falls within the valid code segment of this module, include it in the stack trace. To avoid getting too many false positives, we can add some more constraints."



"Dusting off the RTLI


While having the stack trace in hand is a great step in the right direction, it is still rather cumbersome having to locate the correct copy of the project’s MAP file (providing that we have it somewhere) and then start searching for each logical address from the stack trace.

Ideally, the stack trace itself should include symbolic information such as the unit name, filename, line number and routine name the logical address corresponds to. Thanks to Vitaly Miryanov and his RTLI[ii], we get this wonderful capability almost for free. He has already developed the framework and set of routines to make this possible. We just have to tweak the code a little to make it work with the newer compiler versions."


HVEST was a step in the right direction and using it is certainly better than nothing. If you are already using it you your code today, by all means continue to do so. But time has moved on and there are now more mature solutions available - including the open source JclDebug (as part of the JCL library) and the commercial madExcept, Exceptional Magic and EurekaLog. JclDebug was in part based on my HVEST code and brought forward by Petr Vones and others. If you haven't already, you should seriously consider using one of these - you will not regret it, believe me! ;)

As usual you can read the full article (PDF) and download the full, original code (zip). Enjoy!




[i] Matt Pietrek, MSJ March 1994: Peering inside the PE: A Tour of the Win32 Portable Executable File Format: http://msdn.microsoft.com/library/techart/msdn_peeringpe.htm


[ii] Vitaly Miryanov, TDM Issue 22, June 1997, Run-Time Location Information In Delphi 2

Tuesday, March 11, 2008

TDM#8: DelayLoading Of DLLs

"I don’t miss many features from Microsoft’s Visual C++ 6.0 when working in Delphi, but the new /DELAYLOAD option of the linker is one of them. This option lets you turn normal, implicit DLL import libraries into so-called delayload import libraries. This means that the DLL will not be loaded by the operating system (OS) during start-up of the EXE file, but rather on an as-needed basis when you actually call the routines. The first time a specific DLL routine is called, the DLL is loaded with LoadLibrary and the routine address is retrieved with GetProcAddress. This is accomplished simply by turning on the /DELAYLOAD option of the linker, specifying what DLLs you want to be delayloaded. In this article, we will show how we can implement a framework for easily accomplishing similar behavior in our Delphi applications."

H.Vassbotn, The Delphi Magazine, March 1999

This is one of the TDM articles I'm most satisfied with. It covers a fairly useful subject and technique and it contains some tricky, hacky code that is challenging to explain and get your head around. It is a neat hack that feels a little bit like magic ;).

When writing the article I was inspired by MSJ articles about DELAYLOAD by Matt Pietrek and Jeffrey Richter. In addition I looked at similar code for 16-bit Delphi written by Peter Sawatzki.

A couple more excerpts from the article and code:

"Effortless Explicit Loading

The goal we should set is to write a support unit that will enable us to do dynamic explicit linking just as easily as implicit linking. For the solution that we will go through, we will actually achieve all the stated benefits while being able to write simple import units like the one [below]."

unit DynLinkTest;
interface
uses
HVDll;
var
Routine1 : procedure (A, B, C, D: integer); register;
Routine2 : procedure (A, B, C, D: integer); pascal;
Routine3 : procedure (A, B, C, D: integer); cdecl;
Routine4 : procedure (A, B, C, D: integer); stdcall;
TestDll: TDll;
implementation
var
Entries : array[1..4] of HVDll.TEntry =
((Proc: @@Routine1; Name: 'Routine1'),
(Proc: @@Routine2; Name: 'Routine2'),
(Proc: @@Routine3; ID : 3),
(Proc: @@Routine4; ID : 4));
initialization
TestDll := TDll.Create('Testdll.dll', Entries);
end.


"Generating Code on the Fly

To allow us to use the procedural variables without more code than we saw in Listing 5, we must somehow dynamically compile code thunks similar to the ones we saw back in Listing 3. This requires acting like a mini-compiler and generating executable code on the fly. To complicate matters, we have to preserve the stack-layout and the contents of parameter passing registers (EAX, EDX and ECX). A single set of code must handle all cases of calling conventions and parameters.

As the first step, the CreateThunks method is responsible for dynamically creating these code thunks. Essentially, it allocates a block of memory and then fills it with CPU instruction op-codes, see [the code below]."

procedure TDll.CreateThunks;
const
CallInstruction = $E8;
PushInstruction = $68;
JumpInstruction = $E9;
var
i : integer;
begin
Dlls.CodeHeap.GetMem(FThunkingCode, SizeOf(TThunkHeader) +
SizeOf(TThunk) * Count);
with FThunkingCode^, ThunkHeader do
begin
PUSH := PushInstruction;
VALUE := Self;
JMP := JumpInstruction;
OFFSET := PChar(@ThunkingTarget) - PChar(@Thunks[0]);
for i := 0 to Count-1 do
with Thunks[i] do
begin
CALL := CallInstruction;
OFFSET := PChar(@ThunkHeader) - PChar(@Thunks[i+1]);
end;
end;
end;


"The Inner Workings of ThunkingTarget

When one of the procedural variables are called through, control will be transferred to the corresponding thunk. From here it calls back up to the per-DLL header, pushes the Self-pointer and jumps on to the ThunkingTarget procedure. This procedure is a bit tricky and it has to be written in assembly to allow us to save the contents of certain registers, see [the code below]."

procedure ThunkingTarget;
asm
PUSH EAX
PUSH EDX
PUSH ECX
MOV EAX, [ESP+12] // Self
MOV EDX, [ESP+16] // Thunk
SUB EDX, TYPE TThunk
CALL TDll.DelayLoadFromThunk
MOV [ESP+16], EAX
POP ECX
POP EDX
POP EAX
ADD ESP, 4
// "RETurn" to the DLL!
end;


"Using the Classes

We have now been through the inner workings of the HVDll unit. What might be more useful in the long run, is to know how the classes can be used for everyday work. I have included the public interface of the TDll class [below]."

TDll = class(TObject)
public
constructor Create(const DllName: string; const Entries: array of TEntry);
destructor Destroy; override;
procedure Load;
procedure Unload;
function HasRoutine(Proc: PPointer): boolean;
function HookRoutine(Proc: PPointer; HookProc: Pointer; var OrgProc): boolean;
function UnHookRoutine(Proc: PPointer; var OrgProc): boolean;
property FullPath: string read FFullPath write SetFullPath;
property Handle: HMODULE read GetHandle;
property Loaded: boolean read GetLoaded;
property Available: boolean read GetAvailable;
property Count: integer read FCount;
property EntryName[Index: integer]: string read GetEntryName;
end;

In addition to the main article, there are also a number of side bars of varying degree of length, relevance and interest - the side bars are:



  • Proper [run-time] Code Generation

  • The Case of the Broken Breakpoints

  • Calling Performance and Package Overhead

  • Gotcha! Using SizeOf in BASM

We might revisit a coupe of these in the blog later.


Go ahead to download and read the full article (PDF) and code.

Thursday, March 06, 2008

TDM#7: Design Patterns; Singleton

"In their book Design Patterns, Gamma et al (a.k.a. the gang of four) lay the foundation for a new way of approaching software design. [...] In this article we will first look at the language elements that are unique to Object Pascal when compared to C++ and how this makes many of the problems the design patterns try to solve, non-existent, or at least much easier to solve. Then we will look at one example of a very simple design pattern, the Singleton pattern, and how this can best be implemented in Delphi."

H.Vassbotn, The Delphi Magazine, January 1999

This is one of my higher level TDM articles. It revolves around the discussion of the Singleton pattern and implementing it in a reusable fashion in Delphi. Singleton is one of the design patterns with a more dubious value - it is not well suited for multithreaded code and often it preemptively decides that there should only be a single instance of a specific class. Nevertheless, it can have its uses and the article does show some hacks to make the default constructor and destructor unavailable, for instance.

"Even if the goal of designing a Singleton class might seem very simple, there are a number of points we must consider:

· When and by whom should the single instance be created?
· When and by whom should the single instance be destroyed?
· How should external clients get access to the single instance?
· How can we avoid that the value of the instance reference is corrupted?
· How can we avoid illegal creation of additional instances?
· How can we avoid illegal destruction of the single instance?
· How can we keep the design of the Singleton class, but still allow extension by inheritance?"

At the time, class variables were not present in the language, something I bemoan in the article. However, my idea of a useful class variable implementation differs from what we eventually got (and what most sane men would expect ;) ).

"Class fields is such a unusual concepts for most Pascal programmers, so many find it hard to grasp how they should work, if they were part of the language. In OP we do have hard-coded, read only class fields, such as ClassName, InstanceSize, RTTI pointers etc. These are accessed through class functions, but the actual information is stored as part of the extended VMT (virtual method table). This is how class fields should be implemented as well. A class field follows the VMT, so each new derived class has a separate copy of the class field slot."

So I wanted proper per-class (per-VMT) class variables, not the global-variables-in-disguise class vars we have now (each child class shares the class var it inherits with all other classes in the same part of the hierarchy). This has since been discussed in this log here and here.

Another amusing part of the article is my need to uphold the merits of the Delphi Object Pascal Language.

"Object Pascal as a better language

Many people (not to mention the popular computer press) tend to believe that Object Pascal (OP from now on) has only a subset of the language features of C++. While it is true that OP lacks features like multiple inheritance, operator overloading (except for the array subscript operator [..]) and templates, it still has an array of language features not found in C++. Over the years OP has borrowed many features from C++, for good or for worse. I sincerely hope they will not copy all of them – C++ is such a complex language with many pitfalls for both the novice and experienced programmer.

If we look at the language elements unique to OP, we find an amazing array of useful features: units, sets, sub-ranges, native DLL support, class types, class reference variables, virtual class methods, virtual constructors, extensive runtime type-information (RTTI), message methods, dynamic methods, the override keyword, properties, the try..finally clause, initialization and finalization sections, variants, threadvars, native COM support, interfaces, packages, dynamic arrays, interface delegation, automatic reference counting mechanism, and method pointers. I could go on. This is not intended as an exercise in C++ bashing, but rather an attempt to heighten our awareness of the goodies of OP we are enjoying daily."

Well, today we do have proper operator overloading and a template-like facility is (or will become for Win32) available in the form of generics. Still, I do stand by the statement that Object Pascal is a rich, capable and easy-to-use language.

Here is the general, reusable part of the Singleton code:

unit HVSingleton;

interface

uses
SysUtils;

type
ESingleton = class(Exception);

TInvalidateDestroy = class(TObject)
protected
class procedure SingletonError;
public
destructor Destroy; override;
end;

TSingletonOpaqueInfo = record end;
TSingletonHandle = ^TSingletonOpaqueInfo;
TSingleton = class;
TSingletonClass = class of TSingleton;
TSingleton = class(TInvalidateDestroy)
private
class procedure Startup;
class procedure Shutdown;
protected
// Allow descendents register themselves
class function RegisterSingletonClass(aSingletonClass: TSingletonClass): TSingletonHandle;
// Allow descendents to set a new class for the instance:
class procedure OverrideSingletonClass(BaseSingletonClass, NewSingletonClass: TSingletonClass);
// Interface for descendents to get their instance pointer
class function InstanceOf(Handle: TSingletonHandle): TSingleton;
// Actual constructor and destructor that will be used:
constructor SingletonCreate; virtual;
destructor SingletonDestroy; virtual;
public
// Not for use - for obstruction only:
class procedure Create;
class procedure Free(Dummy: integer);
{$IFNDEF VER120} {$WARNINGS OFF} {$ENDIF}
// This generates a warning in D3. D4 has the reintroduce keyword to solve this
class procedure Destroy(Dummy: integer); {$IFDEF VER120} reintroduce; {$ENDIF}
end;
{$IFNDEF VER120} {$WARNINGS ON} {$ENDIF}

implementation

uses
Classes;

{ TInvalidateDestroy }

class procedure TInvalidateDestroy.SingletonError;
// Raise an exception in case of illegal use
begin
raise ESingleton.CreateFmt('Illegal use of %s singleton instance!', [ClassName]);
end;

destructor TInvalidateDestroy.Destroy;
// Protected against use of default destructor
begin
SingletonError;
end;

{ TSingleton }

var
SingletonInstances : TList; { of TSingletons }
SingletonClasses : TList; { of TSingletonClasses }

class procedure TSingleton.Startup;
begin
SingletonInstances := TList.Create;
SingletonClasses := TList.Create;
end;

class procedure TSingleton.Shutdown;
// Time to close down the show
var
SingletonInstance: TSingleton;
i : integer;
begin
// Free any singleton instances
for i := SingletonInstances.Count-1 downto 0 do
begin
SingletonInstance := TSingleton(SingletonInstances.List^[i]);
if Assigned(SingletonInstance) then
SingletonInstance.SingletonDestroy;
end;
// Free the lists
SingletonInstances.Free; SingletonInstances := nil;
SingletonClasses .Free; SingletonClasses := nil;
end;

class function TSingleton.RegisterSingletonClass(aSingletonClass: TSingletonClass): TSingletonHandle;
// Register a new Singleton class and allocate space for the instance pointer
var
Index: integer;
begin
Assert(Assigned(aSingletonClass));
Assert(SingletonClasses.IndexOf(Pointer(aSingletonClass)) < 0);
SingletonClasses.Add(Pointer(aSingletonClass));
// Return the index +1 of the instace pointer as a handle
Index := SingletonInstances.Add(nil);
Result := TSingletonHandle(Index+1);
Assert(SingletonClasses.Count = SingletonInstances.Count);
end;

class procedure TSingleton.OverrideSingletonClass(BaseSingletonClass, NewSingletonClass: TSingletonClass);
// Allow change of instance class
var
ThisClass: TSingletonClass;
i : integer;
begin
Assert(Assigned(BaseSingletonClass));
Assert(Assigned(NewSingletonClass));
Assert(BaseSingletonClass <> TSingleton);
Assert(NewSingletonClass.InheritsFrom(BaseSingletonClass));
for i := 0 to SingletonClasses.Count-1 do
begin
ThisClass := TSingletonClass(SingletonClasses.List^[i]);
if ThisClass.InheritsFrom(BaseSingletonClass) and
(SingletonInstances.List^[i] = nil) then
begin
SingletonClasses.List^[i] := Pointer(NewSingletonClass);
Exit;
end;
end;
// If we get, here the base class was not found or
// an instance had already been created
SingletonError;
end;

class function TSingleton.InstanceOf(Handle: TSingletonHandle): TSingleton;
// Single Instance function - create when first needed
var
Index: Integer;
begin
// Convert the handle back to an index - subtract 1
Index := Integer(Handle) - 1;
Assert((Index >= 0) and (Index <= SingletonInstances.Count-1));
Assert(Assigned(SingletonClasses.List^[Index]));
if not Assigned(SingletonInstances.List^[Index]) then
SingletonInstances.List^[Index] := TSingletonClass(SingletonClasses.List^[Index]).SingletonCreate;
Result := SingletonInstances.List^[Index];
end;

constructor TSingleton.SingletonCreate;
// Protected constructor
begin
inherited Create;
end;

destructor TSingleton.SingletonDestroy;
// Protected destructor
begin
// We cannot call inherited Destroy; here!
// It would raise an ESingleton exception
end;

// Protected against use of default constructor
class procedure TSingleton.Create;
begin
SingletonError;
end;

// Protected against use of Free
class procedure TSingleton.Free(Dummy: integer);
begin
SingletonError;
end;

// Protected against use of default destructor
class procedure TSingleton.Destroy(Dummy: integer);
begin
SingletonError;
end;

initialization
TSingleton.Startup;
finalization
TSingleton.Shutdown;
end.

Note that the code was written for Delphi 3 and 4 - it will give warnings on later versions (this was before the handy $IF directive and CompilerVersion constant). 


And here is a specific singleton class, that inherits the singleton functionality from the TSingleton class above.

unit HVTimeKeeper2;

interface

uses
HVSingleton;

type
TTimeKeeper = class(TSingleton)
private
function GetTime: TDateTime;
function GetDate: TDateTime;
function GetNow: TDateTime;
public
class function Instance: TTimeKeeper;
property Time: TDateTime read GetTime;
property Date: TDateTime read GetDate;
property Now: TDateTime read GetNow;
end;

function TimeKeeper: TTimeKeeper;

implementation

uses
SysUtils;

{ TTimeKeeper }

var
TimeKeeperHandle: TSingletonHandle;

class function TTimeKeeper.Instance: TTimeKeeper;
// Single Instance function - create when first needed
begin
Result := TTimeKeeper(InstanceOf(TimeKeeperHandle));
end;

// Property access methods
function TTimeKeeper.GetDate: TDateTime;
begin
Result := SysUtils.Date;
end;

function TTimeKeeper.GetNow: TDateTime;
begin
Result := SysUtils.Now;
end;

function TTimeKeeper.GetTime: TDateTime;
begin
Result := SysUtils.Time;
end;

// Simplified functional interface

function TimeKeeper: TTimeKeeper;
begin
Result := TTimeKeeper.Instance;
end;

initialization
TimeKeeperHandle := TTimeKeeper.RegisterSingletonClass(TTimeKeeper);
end.

I think the original plan was to write more articles about design patterns; general discussion, sample Delphi implementations, recognizing existing use of patterns in the VCL and so on. But they never materialized - not in print, anyway; I did stumble over a draft of patterns in the VCL. Maybe I'll revive some of that material on the blog later.


As usual you can download and read the full article (PDF) and code samples.

Sunday, March 02, 2008

TDM#6: Knitting Your Own Threads

One of the key reasons that computers have conquered the world is that they have been following Moore's Law with faster, smaller and cheaper CPUs (and similar "laws" and improvements of memory, hard disks, graphics cards, etc) coming out every year.

Until recently, all programs have just become faster and faster due to improved hardware. This has been dubbed "the free lunch" and has given sloppy programmers the "hardware-will-catch-up" excuse to write slow and bloated software.

Well, no more (this DDJ piece by Herb Sutter is recommended reading). The speed of normal run-of-the-mill single-threaded code are not getting any speedups any more. The main reason for this is that CPU clock speeds have hit the ~3 Ghz speed limit. On the other hand, CPUs are getting better at doing things in parallel - by packing multiple cores in the same die, multiple threads of execution can run at the same time. To exploit this parallelism, programs have to somehow execute multiple threads - so called multithreaded programming.

Even in the classical case of a single CPU core, there can often be substantial benefits of dividing the work of a program into multiple threads. You can improve user interface responsiveness by off-loading some of the heavy lifting to a background thread, for instance, while the main thread is still happily updating the GUI.

Delphi has always (well, since Delphi 2) anyway had some level of support for writing multithreaded applications. There is the TThread class that encapsulates the concept of a separate thread of execution and there are wrappers for critical sections, mutexes, semaphores and events. Allen Bauer is doing an admirable job of thinking, designing, (re-)implementing and writing about an upcoming Delphi Parallel Library (DPL) in his blog.

Still, one of the major weaknesses of the current Delphi VCL thread support is that there is no (easy) way for the main thread to wait for a signal in a non-polling, non-blocking fashion. Another related issue is that there is no clean way for threads to communicate between themselves or the main thread. For performance and blocking reasons, the dreaded TThread.Synchronize method should be avoided.

These are the main points I raised in The Delphi Magazine article Knitting Your Own Threads, published in December 1998 (time sure is flying, that is almost 10 years ago now! :)). It also goes into some detail the various threading support in the compiler, RTL and VCL (we are still in the Delphi 4 era here). It talks about and digs into the implementation and shortcomings of:

  • threadvar
  • MainThreadID
  • IsMultiThread
  • BeginThread / EndThread
  • TThreadFunc
  • TThread (Execute, WaitFor, Synchronize)
  • TThreadList
  • TEvent
  • TCriticalSection

Then it goes on to try and fill in some of the shortcomings, giving implementations and wrappers for (some of these have been covered in later Delphi releases):

  • TSynchroObject
  • THandleObject
  • TNamedObject
  • TMutex
  • TSemaphore
  • TWaitableThreadList
  • TMultiThreadedMainLoop
  • MsgWaitForMultipleObjects (hooking Applicaton.OnIdle)
  • TSignalList

A few excerpts of the article and code:

"[The TWaitableThreadList] class can be used to administer a background working thread. The thread class will keep two TWaitableThreadLists, one InBox for work to be done and one OutBox for worked finished by the thread ready to be picked up by the main thread (or even another work thread for further processing),see example work flow in Figure 2. "

constructor TSignalList.Create;
begin
inherited Create;
FList := TList.Create;
// See MsgWaitForMultipleObjects in help for list of possible values
FMsgWakeupMask := QS_AllInput;
end;

destructor TSignalList.Destroy;
begin
FreeOwningTList(FList);
inherited Destroy;
end;

procedure TSignalList.AddSignal(aSignal: TCustomSignal);
begin
// Check that we are not passing any limits (currently 64!)
if FList.Count >= MAXIMUM_WAIT_OBJECTS then
raise Exception.Create('Too many wait-objects!');

// Update the low-level array with this new handle
FObjs[FList.Count] := aSignal.Handle;

// Add the thread event to the list
FList.Add(aSignal);
end;

procedure TSignalList.TriggeredIndex(Index: integer);
begin
// Use assertions to guarantee correct code while debugging and fast release code
Assert((Index >= 0) and (Index < FList.Count));
Assert(TObject(FList[Index]) is TCustomSignal);
Assert(FObjs[Index] = TCustomSignal(FList[Index]).Handle);

// Get the Signal associated with this index and trigger the event
TCustomSignal(FList.List^[Index]).Trigger;
end;

function TSignalList.WaitOne(WaitTime: DWORD; var Index: integer): TWaitResult;
// We use the blocking function MsgWaitForMultipleObjects to wait for any
// message in the message queue or any signaled object from any of the
// other running threads in this process. See WINAPI32.HLP for details.
var
WaitResult: DWORD;
begin
// This call will block and use 0% CPU time until:
// - A message arrives in the message queue, or
// - Any of the object handles in the Objs array become signaled
if IgnoreMessages
then WaitResult := WaitForMultipleObjects(FList.Count, @FObjs, WaitForAll, WaitTime)
else WaitResult := MsgWaitForMultipleObjects(FList.Count, FObjs, WaitForAll, WaitTime, MsgWakeupMask);

// Index is only valid when Result = wrSignaled
Index := WaitResult - WAIT_OBJECT_0;

// Convert from WAIT_ returncode to TWaitResult
case WaitResult of
WAIT_ABANDONED: Result := wrAbandoned;
WAIT_TIMEOUT : Result := wrTimeout;
WAIT_FAILED : Result := wrError;
else
if WaitResult = DWORD(WAIT_OBJECT_0 + FList.Count)
then Result := wrMessage
else Result := wrSignaled // WAIT_OBJECT_0 .. WAIT_OBJECT_0+(FList.Count-1)
end;
end;

function TSignalList.WaitOneAndTrigger(WaitTime: DWORD): TWaitResult;
var
Index: integer;
begin
Result := WaitOne(WaitTime, Index);
if Result = wrSignaled then
TriggeredIndex(Index);
end;

function TSignalList.WaitUntil(WaitTime: DWORD; WaitResultStop: TWaitResults): TWaitResult;
begin
repeat
Result := WaitOneAndTrigger(WaitTime);
until (Result in WaitResultStop);
end;


"Now that we have a nice encapsulation of MsgWaitForMultipleObjects to work with, lets continue with adding the improved threading capability to the main thread of the application (and thus the VCL). As we discussed, this is accomplished by hooking the OnIdle event of TApplication. See the source code of the TMultiThreadedMainLoop class in the HVMultiThreadMain unit."

procedure TMultiThreadedMainLoop.AppIdle(Sender: TObject; var Done: boolean);
// Whenever the application becomes idle, i.e. there are no messages in the
// message queue, this procedure is entered.
begin
// The default case for the old idle event
// handler should be that it is done processing
Done := true;

// Call any old idle event handler
// - this could be extended with an idle hook chain
if Assigned(FOldAppIdle) then
FOldAppIdle(Sender, Done);

// WaitUntil handles all signaled objects for the main thread
if Done then
// If the old idle event handler is done,
// wait until there is a message for us (blocking)
FSignalList.WaitUntil(INFINITE, [wrMessage])
else
// If the old idle event handler is not done yet,
// just check for signaled objects or messages (non-blocking)
FSignalList.WaitUntil(0 , [wrMessage, wrTimeOut]);

// Tell the timer-loop that we have actully been idle
FHasBeenIdle := true;

// Now return to the message loop in TApplication and
// let it have a look at the message for us
// Note that we will normally return with Done = true.
// This will call WaitMessage in TApplication.Idle, but it will not
// block because we already know there is a message in the message queue
end;

Continue to read the full article (PDF) and download the code.



Copyright © 2004-2007 by Hallvard Vassbotn