The Wiert Corner – irregular stream of stuff

Jeroen W. Pluimers on .NET, C#, Delphi, databases, and personal interests

  • My badges

  • Twitter Updates

  • My Flickr Stream

  • Pages

  • All categories

  • Enter your email address to subscribe to this blog and receive notifications of new posts by email.

    Join 2,161 other followers

“Don’t access VCL from a background thread” – how to demo that?

Posted by jpluimers on 2018/07/11

When accessing the VCL from multiple threads at the same time: adopted from ...\DEMOS\THREADS\THRDDEMO.DPR

When accessing the VCL from multiple threads at the same time: adopted from …\DEMOS\THREADS\THRDDEMO.DPR

Great question a while ago:

[WayBack] “Don’t access VCL from a background thread” – how to demo that? – Primož Gabrijelčič – Google+

For me, the ultimate way why not to access the VCL from a background thread is the precursor of the official threads demo that ships from Delphi 2 to Delphi XE6 in ...DEMOS\THREADS\THRDDEMO.DPR. where you’d think the thread isolation would be in ...DEMOS\THREADS\ThSort.pas but actually is in ...DEMOS\THREADS\SortThds.pas.

The first public showing of that demo did not include main thread protection. It originates from a session at the the 1995 Borland Developers Conference where Ray Konopka showed the below code from Bob Ainsbury.

That session reminded why this joke [WayBack] Via the EKON20 sessions… – Jeroen Wiert Pluimers – Google+ was so funny:  “When Ray Konopka enters the room you have a Raize condition.“.

The question above also made me find back this reference to BorCon95 in San Diego:

[WayBackInterview with Ray Konopka by Clay Shannon: Ray Konopka talks about the mechanics of the Borland Conference advisory board, his work on Code Site for .NET, the great BorCon pizza thread time slice demonstration, his High School record in Track and Field, and Octane

<<

What was the funniest experience you’ve ever had related to programming?

At the Borland Conference in San Diego in 1995, Bob Ainsbury and I presented a session on multithreaded programming in Delphi. (Well, it was actually an alpha version of Delphi32.) About halfway through the session Bob starts talking about scheduling and says that maybe a demonstration would be helpful. Bob then selects three volunteers from the audiencetwo men and one woman.

With the three volunteers up at the front, Bob directs me to come out from behind the computer. At this point, I had absolutely no idea where all this was heading. Bob had asked me to help with his session that morning and while I worked on a big demonstration program for the session, he worked on the rest of his presentation. The point is that I did not see any of Bobs slides or other material until he showed them in the session.

Bob then tells me that I will be the scheduler and the three volunteers are threads. Bob then gives each person (i.e. thread) a priority level both men get the same priority value while the woman gets a slightly lower value.

Bob then brings out some slices of rather cold pizza and puts them on the table in front of the three threads. Bob then explains that each thread gets to do work when the scheduler gives the thread a time slice. In other words, when I point to a thread, that person is to pick up a pizza slice and take a bite.

Next, Bob tells me to schedule the first thread, so I point to one of the men and he takes a bite of pizza. Bob then tells me to switch to the next thread, so I point to the other man, and he takes a bite of pizza. Again, Bob tells me to switch threads, so I point back to the first man as the woman has a lower priority value, and the man takes another bite. At this point, the audience is really getting into it. Bob then has me switching threads more quickly and these two guys, who were great sports, kept taking bites of pizza. By now, everyone was laughing, including the woman who did not have to stuff her face full of pizza. Of course, in the end, Bob explained how this illustrated how a thread can be starved.

>>

At that conference, I made an epic stage appearance winning a beer bottle from a quiz question, but not being to open it. One of the first times in the USA for me, I didn’t know what a “twist off” was and my opener was in the hotel room (:

As Ray Konopka is still in the Delphi world with [WayBackRaize Software, lots of people still know him. Some people [Archive.is] wondered whatever happened to Bob Ainsbury (he was already famous in the DOS era for his DOS 6 Secrets book and Turbo Vision era for his free “TechnoJocks Turbo Toolkit” and “TechnoJock’s Object Toolkit”, but moved on from the Delphi world a long time ago). He is @bainsbury and has a [Archive.isbroad belt of tools for his work.

Back to ...DEMOS\THREADS\THRDDEMO.DPR:

I’m not sure why they removed the multi-threading demo, so since the heritage, I made it into a gist.

The trick is to remove the Synchronize call in the VisualSwap method below. It is the basic way of ensuring a parameterless executes in the main VCL thread:

More simple demo to crash the VCL

In the end Primož went with this:

Found a simple one.

Create a new VCL program. Drop a TImage on the form. Insert this code:

procedure TForm47.FormCreate(Sender: TObject);
begin
  TThread.CreateAnonymousThread(
  procedure
  begin
    PaintToImage(Image1);
  end).Start;
end;

procedure TForm47.PaintToImage(image: TImage);
begin
  while true do begin
    Image1.Picture.Bitmap := TBitmap.Create;
    Image1.Picture.Bitmap.Free;
  end;
end;

Run in debugger. Instant access violation in the WMPaint handler of the main thread.

–jeroen

unit SortThds;
interface
uses
Classes, Graphics, ExtCtrls;
type
{ TSortThread }
PSortArray = ^TSortArray;
TSortArray = array[0..MaxInt div SizeOf(Integer) – 1] of Integer;
TSortThread = class(TThread)
private
FBox: TPaintBox;
FSortArray: PSortArray;
FSize: Integer;
FA, FB, FI, FJ: Integer;
procedure DoVisualSwap;
protected
procedure Execute; override;
procedure VisualSwap(A, B, I, J: Integer);
procedure Sort(var A: array of Integer); virtual; abstract;
public
constructor Create(Box: TPaintBox; var SortArray: array of Integer);
end;
{ TBubbleSort }
TBubbleSort = class(TSortThread)
protected
procedure Sort(var A: array of Integer); override;
end;
{ TSelectionSort }
TSelectionSort = class(TSortThread)
protected
procedure Sort(var A: array of Integer); override;
end;
{ TQuickSort }
TQuickSort = class(TSortThread)
protected
procedure Sort(var A: array of Integer); override;
end;
procedure PaintLine(Canvas: TCanvas; I, Len: Integer);
implementation
procedure PaintLine(Canvas: TCanvas; I, Len: Integer);
begin
Canvas.PolyLine([Point(0, I * 2 + 1), Point(Len, I * 2 + 1)]);
end;
{ TSortThread }
constructor TSortThread.Create(Box: TPaintBox; var SortArray: array of Integer);
begin
inherited Create(False);
FBox := Box;
FSortArray := @SortArray;
FSize := High(SortArray) – Low(SortArray) + 1;
FreeOnTerminate := True;
end;
{ Since DoVisualSwap uses a VCL component (i.e., the TPaintBox) it should never
be called directly by this thread. DoVisualSwap should be called by passing
it to the Synchronize method which causes DoVisualSwap to be executed by the
main VCL thread, avoiding multi-thread conflicts. See VisualSwap for an
example of calling Synchronize. }
procedure TSortThread.DoVisualSwap;
begin
with FBox do
begin
Canvas.Pen.Color := clBtnFace;
PaintLine(Canvas, FI, FA);
PaintLine(Canvas, FJ, FB);
Canvas.Pen.Color := clRed;
PaintLine(Canvas, FI, FB);
PaintLine(Canvas, FJ, FA);
end;
end;
{ VisusalSwap is a wrapper on DoVisualSwap making it easier to use. The
parameters are copied to instance variables so they are accessable
by the main VCL thread when it executes DoVisualSwap }
procedure TSortThread.VisualSwap(A, B, I, J: Integer);
begin
FA := A;
FB := B;
FI := I;
FJ := J;
Synchronize(DoVisualSwap);
end;
{ The Execute method is called when the thread starts }
procedure TSortThread.Execute;
begin
Sort(Slice(FSortArray^, FSize));
end;
{ TBubbleSort }
procedure TBubbleSort.Sort(var A: array of Integer);
var
I, J, T: Integer;
begin
for I := High(A) downto Low(A) do
for J := Low(A) to High(A) – 1 do
if A[J] > A[J + 1] then
begin
VisualSwap(A[J], A[J + 1], J, J + 1);
T := A[J];
A[J] := A[J + 1];
A[J + 1] := T;
if Terminated then Exit;
end;
end;
{ TSelectionSort }
procedure TSelectionSort.Sort(var A: array of Integer);
var
I, J, T: Integer;
begin
for I := Low(A) to High(A) – 1 do
for J := High(A) downto I + 1 do
if A[I] > A[J] then
begin
VisualSwap(A[I], A[J], I, J);
T := A[I];
A[I] := A[J];
A[J] := T;
if Terminated then Exit;
end;
end;
{ TQuickSort }
procedure TQuickSort.Sort(var A: array of Integer);
procedure QuickSort(var A: array of Integer; iLo, iHi: Integer);
var
Lo, Hi, Mid, T: Integer;
begin
Lo := iLo;
Hi := iHi;
Mid := A[(Lo + Hi) div 2];
repeat
while A[Lo] < Mid do Inc(Lo);
while A[Hi] > Mid do Dec(Hi);
if Lo <= Hi then
begin
VisualSwap(A[Lo], A[Hi], Lo, Hi);
T := A[Lo];
A[Lo] := A[Hi];
A[Hi] := T;
Inc(Lo);
Dec(Hi);
end;
until Lo > Hi;
if Hi > iLo then QuickSort(A, iLo, Hi);
if Lo < iHi then QuickSort(A, Lo, iHi);
if Terminated then Exit;
end;
begin
QuickSort(A, Low(A), High(A));
end;
end.

view raw
SORTTHDS.PAS
hosted with ❤ by GitHub

program ThrdDemo;
uses
Forms,
ThSort in 'ThSort.pas' {ThreadSortForm},
SortThds in 'SortThds.pas';
{$R *.RES}
begin
Application.CreateForm(TThreadSortForm, ThreadSortForm);
Application.Run;
end.

view raw
THRDDEMO.DPR
hosted with ❤ by GitHub

object ThreadSortForm: TThreadSortForm
Left = 212
Top = 110
BorderStyle = bsDialog
Caption = 'Thread Sorting Demo'
ClientHeight = 295
ClientWidth = 562
Font.Color = clWindowText
Font.Height = –11
Font.Name = 'MS Sans Serif'
Font.Style = []
Position = poScreenCenter
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Bevel1: TBevel
Left = 8
Top = 24
Width = 177
Height = 233
end
object Bevel3: TBevel
Left = 376
Top = 24
Width = 177
Height = 233
end
object Bevel2: TBevel
Left = 192
Top = 24
Width = 177
Height = 233
end
object BubbleSortBox: TPaintBox
Left = 8
Top = 24
Width = 177
Height = 233
OnPaint = BubbleSortBoxPaint
end
object SelectionSortBox: TPaintBox
Left = 192
Top = 24
Width = 177
Height = 233
OnPaint = SelectionSortBoxPaint
end
object QuickSortBox: TPaintBox
Left = 376
Top = 24
Width = 177
Height = 233
OnPaint = QuickSortBoxPaint
end
object Label1: TLabel
Left = 8
Top = 8
Width = 55
Height = 13
Caption = 'Bubble Sort'
end
object Label2: TLabel
Left = 192
Top = 8
Width = 66
Height = 13
Caption = 'Selection Sort'
end
object Label3: TLabel
Left = 376
Top = 8
Width = 50
Height = 13
Caption = 'Quick Sort'
end
object StartBtn: TButton
Left = 480
Top = 264
Width = 75
Height = 25
Caption = 'Start Sorting'
TabOrder = 0
OnClick = StartBtnClick
end
end

view raw
THSORT.DFM
hosted with ❤ by GitHub

unit ThSort;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;
type
TThreadSortForm = class(TForm)
StartBtn: TButton;
BubbleSortBox: TPaintBox;
SelectionSortBox: TPaintBox;
QuickSortBox: TPaintBox;
Label1: TLabel;
Bevel1: TBevel;
Bevel2: TBevel;
Bevel3: TBevel;
Label2: TLabel;
Label3: TLabel;
procedure BubbleSortBoxPaint(Sender: TObject);
procedure SelectionSortBoxPaint(Sender: TObject);
procedure QuickSortBoxPaint(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure StartBtnClick(Sender: TObject);
private
ThreadsRunning: Integer;
procedure RandomizeArrays;
procedure ThreadDone(Sender: TObject);
public
procedure PaintArray(Box: TPaintBox; const A: array of Integer);
end;
var
ThreadSortForm: TThreadSortForm;
implementation
uses SortThds;
{$R *.DFM}
type
PSortArray = ^TSortArray;
TSortArray = array[0..114] of Integer;
var
ArraysRandom: Boolean;
BubbleSortArray, SelectionSortArray, QuickSortArray: TSortArray;
{ TThreadSortForm }
procedure TThreadSortForm.PaintArray(Box: TPaintBox; const A: array of Integer);
var
I: Integer;
begin
with Box do
begin
Canvas.Pen.Color := clRed;
for I := Low(A) to High(A) do PaintLine(Canvas, I, A[I]);
end;
end;
procedure TThreadSortForm.BubbleSortBoxPaint(Sender: TObject);
begin
PaintArray(BubbleSortBox, BubbleSortArray);
end;
procedure TThreadSortForm.SelectionSortBoxPaint(Sender: TObject);
begin
PaintArray(SelectionSortBox, SelectionSortArray);
end;
procedure TThreadSortForm.QuickSortBoxPaint(Sender: TObject);
begin
PaintArray(QuickSortBox, QuickSortArray);
end;
procedure TThreadSortForm.FormCreate(Sender: TObject);
begin
RandomizeArrays;
end;
procedure TThreadSortForm.StartBtnClick(Sender: TObject);
begin
RandomizeArrays;
ThreadsRunning := 3;
with TBubbleSort.Create(BubbleSortBox, BubbleSortArray) do
OnTerminate := ThreadDone;
with TSelectionSort.Create(SelectionSortBox, SelectionSortArray) do
OnTerminate := ThreadDone;
with TQuickSort.Create(QuickSortBox, QuickSortArray) do
OnTerminate := ThreadDone;
StartBtn.Enabled := False;
end;
procedure TThreadSortForm.RandomizeArrays;
var
I: Integer;
begin
if not ArraysRandom then
begin
Randomize;
for I := Low(BubbleSortArray) to High(BubbleSortArray) do
BubbleSortArray[I] := Random(170);
SelectionSortArray := BubbleSortArray;
QuickSortArray := BubbleSortArray;
ArraysRandom := True;
Repaint;
end;
end;
procedure TThreadSortForm.ThreadDone(Sender: TObject);
begin
Dec(ThreadsRunning);
if ThreadsRunning = 0 then
begin
StartBtn.Enabled := True;
ArraysRandom := False;
end;
end;
end.

view raw
THSORT.PAS
hosted with ❤ by GitHub

2 Responses to ““Don’t access VCL from a background thread” – how to demo that?”

  1. Primož Gabrijelčič said

    Also see ParallelPaint demo in https://github.com/PacktPublishing/Delphi-High-Performance/tree/master/Chapter%205

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out /  Change )

Google photo

You are commenting using your Google account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s

This site uses Akismet to reduce spam. Learn how your comment data is processed.

 
%d bloggers like this: