“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
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:
[WayBack] Interview 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 [WayBack] Raize 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.is] broad 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:
- [WayBack]
unit classes; procedure TThread.Synchronize(AMethod: TThreadMethod); overload; - [WayBack]
unit classes; TThreadMethod = procedure of object;
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. |
| program ThrdDemo; | |
| uses | |
| Forms, | |
| ThSort in 'ThSort.pas' {ThreadSortForm}, | |
| SortThds in 'SortThds.pas'; | |
| {$R *.RES} | |
| begin | |
| Application.CreateForm(TThreadSortForm, ThreadSortForm); | |
| Application.Run; | |
| end. |
| 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 |
| 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. |
Primož Gabrijelčič said
Also see ParallelPaint demo in https://github.com/PacktPublishing/Delphi-High-Performance/tree/master/Chapter%205
jpluimers said
Thanks!