Renate Schaaf

Confirmed: Works with uProf now. Great Job. I get the same info as with VTune: hotspot timings, processor use, stack graph.

Meanwhile I've followed your suggestions and rewrote the algorithm so it writes one line at a time. Sadly, I couldn't give SuperDuper a chance to shine, as I would need to transpose memory in chunks of 16 Bytes instead of 4. Still, it got a little faster, and since both unthreaded routines are faster than Graphics32, I don't think I'm doing so badly. For the threaded version I used with a minimum of 2 and a maximum of 8 threads. Is rather fast if it works. Sadly the fails for the tasks version became, if anything, more frequent, and a Tparallel.for version hung indefinitely a few times. I failed to completely recover from the timeouts, after a fail the next call would likely fail again. So, finally I just set up 8 oldfashioned threads which wake up as needed, do a chunk of the work as needed and signal that they're done. I didn't even bother to put in checks for timeouts. It's the fastest yet and has never failed so far. Guess that is a strong indication that the culprit was TTask. If you are curious, here is a 720x540 video that got written at 40 FPS, a new record for me 🙂. Once I do similar optimizations for the transitions, the writing speed might be acceptable. Thanks again to all!

W and Height are the size in byte of the memory chunk? Do you transpose byte by byte, I guess not, wouldn't make any sense for bgra-records. Well, I need to play around with it. Pity I don't read ASM. Is this for 32bit only? Thanks 🙂

It isn't, the creation of the threads takes too long, in the end the procedure takes about twice the time of the unthreaded one. I would really hate to have to use the approach with waking up existing threads to do the resampling ... I introduced the timeout, because the first time this happened, I had to kill the application. I am right to assume then, that there isn't anything obviously wrong in my approach which would cause the timeout? This is true for the target, and to a degree of the source, too. But the intermediate Columnx is in fact a "row" the way it's allocated. But you are right; and maybe one can get away without the transposing. Also, if the intermediate storage is a TBitmap, the algorithms wouldn't be "symmetric" anymore, the transpose of the target wouldn't be the same as the target of the transpose, but that's probably just nitpick. Anyway, if you'd care to share the code for the transposing, I'd be glad. I didn't know that. Thanks. Another point in favor of doing complete rows first, or to have the threads compute chunks of full rows. Thank you all, I have a lot to do.

Good idea, but I'm doing zoom-pans, the fixed resizing I leave to the video-encoder to do. I want to be reasonably sure that this runs on any system, not just mine .. Time to do some more stress tests 🙂

Thanks, I will try this. I've also tried to change to TParallel.for, which hasn't bugged out so far, but is more erratic timing wise. Problem is, that the error occurs so very rarely, it's hard to say whether or not it's fixed. I wish I had more insight into what could go wrong. Thx Renate

I agree that it isn't very nice to just dump the source code here. So here is the explanation: In the routines, nevermind SourceRect, imagine it to be the full rect of the source bitmap. The Radius isn't important either. Contributors: For pixel(x,y) in the target, ContribsX[x] is a record, that defines the range of x-Values of pixels in the source, which contribute to the value of p(x,y). The record also contains the weights which have to be applied before summing up. The further away from the center of the range, the lower the weight (simplified). The range and the weights are independent of y, so the array ContribsX is computed in advance. ContribsY[y] does the same for the source pixels in y-direction. The way the contributors are computed isn't important here, it's done outside of the tasks. Pseudo-Code for computing p(x,y): (ps is a source pixel) (Imagine the weights to be floats, and results being rounded) p(x,y) := 0; for i:=0 to ContribsX[x].high do for j:= 0 to ContribsY[y].high do p(x,y) := p(x,y) + ContribsX[x].Weights[i] * ContribsY[y].Weights[j] * ps(ContribsX[x].min + i, ContribsY[y].min + j); Since this isn't very efficient and can't well be divided into tasks, the averaging in x- and y-direction is done separately. Here's where the routine ProcessColumn comes in, it's the most important procedure, and it writes one column of the target bitmap's memory in 2 steps: PseudoCode for ProcessColumn: (x is given, Compute Column at x) Step 1: resample to intermediate array ColumnX: for ys:= 0 to OldHeight-1 do begin ColumnX[ys] := 0; for i:=0 to ContribsX[x].high do ColumnX[ys] := ColumnX[ys] + ContribsX[x].Weights[i]*ps(ContribsX[x].min +i, ys); end; Step 2: resample ColumnX to the target column: for y := 0 to NewHeight-1 do begin p(x,y):=0; for j := 0 to ContribsY[y].high do p(x,y) := p(x,y) + ContribsY[y].Weights[j]*ColumnX[ContribsY[y].min + j]; end; The tasks just write 4 different chunks of colums, but they all read from the same source-bitmap-memory and from the same contributor-arrays. The original source code is obfuscated by (at least:) 2 things: Values that should be float have been scaled to integers Pointers are used to walk along the arrays I'm afraid that's still too long. ..Make it shorter ...Again, half the size Gruß, Renate

I'll try but it ain't easy. More than 10 years ago I spent days reading your code, before I understood what made it tick 🙂

I've tried to divide the work for resizing bitmaps into 4 parallel tasks. The result is, on average, a speed improvement by 60%, the bicubic resampler gets close to StretchBlt/Halftone. I'm using the routine for writing videos, where it is called at least once for every video frame. So, in my tests I must have called it at least 100 000 times. Problem is, that 3 times there was a timeout in TTask.WaitForAll. I'm not using any synchronization, because The tasks are completely independent of each other, i.e. none alters anything that the other uses. They write to memory chunks, which do not overlap. They don't use any VCL-code, not even VCL.Graphics. The memory they read does overlap, but I thought that was OK, but after reading up a bit, I get the impression that I am wrong here. From what I gather, I have a "race condition" caused by "not atomic reads" (this is all very new to me, sorry, if I'm talking rubbish). The threads are (among other things) all reading from two contributor-arrays, which contain records of varying size, so could that be it? What can I do to prevent the error? Maybe I should make copies of the arrays for each task? Here is the unit, it only uses a bicubic filter to make things a little simpler: unit uResample; interface uses WinApi.Windows, System.Types, VCL.Graphics, System.SysUtils, System.Classes, System.Math; type TZoomProcedure = procedure(const Source, Target: TBitmap; SourceRect: TRectF; Radius: single); // "bicubic" resampler based on ideas by Anders Melander, Mike Lischke // and Eric Grange. It supports float values for filter radii and float-valued // zoom rectangles. Source, Target should be pf32bit. Target must be set to the // correct size. procedure ZoomResample(const Source, Target: TBitmap; SourceRect: TRectF; Radius: single); // Same as above divided into 4 parallel tasks procedure ZoomResampleParallel(const Source, Target: TBitmap; SourceRect: TRectF; Radius: single); implementation uses WinApi.MMSystem, VCL.Dialogs, System.SyncObjs, System.Threading; type TContributor = record min, High: integer; // Min: start source pixel // High+1: number of source pixels to contribute to the result Weights: array of integer; // doubles scaled by $800 end; TContribArray = array of TContributor; TBGRAInt = record b, g, r, a: integer; end; PBGRAInt = ^TBGRAInt; TBGRAIntArray = array of TBGRAInt; const beta = 0.525; // f(beta)=0 beta2 = beta * beta; alpha = 105 / (16 - 112 * beta2); aa = 1 / 7 * alpha; bb = -1 / 5 * alpha * (2 + beta2); cc = 1 / 3 * alpha * (1 + 2 * beta2); dd = -alpha * beta2; // constants computed with maple for polynomial fit function AntiFilter(X: double): double; inline; // Antiderivative of a filter function similar to bicubic, but I like it better begin if X < -1 then Result := -0.5 else if X < 1 then Result := aa * X * X * X * X * X * X * X + bb * X * X * X * X * X + cc * X * X * X + dd * X else Result := 0.5; end; procedure MakeContributors(r: single; SourceSize, TargetSize: integer; SourceStart, SourceFloatwidth: double; var Contribs: TContribArray); // r: Filterradius var xCenter, scale, rr: double; X, j: integer; x1, x2, delta: double; TrueMin, TrueMax, Mx: integer; begin Assert(TargetSize > 0); if SourceFloatwidth = 0 then SourceFloatwidth := SourceSize; scale := SourceFloatwidth / TargetSize; SetLength(Contribs, TargetSize); if scale > 1 then // downsampling rr := r * scale else rr := r; delta := 1 / rr; for X := 0 to TargetSize - 1 do begin xCenter := (X + 0.5) * scale; TrueMin := Ceil(xCenter - rr + SourceStart - 1); TrueMax := Floor(xCenter + rr + SourceStart); Contribs[X].min := min(max(TrueMin, 0), SourceSize - 1); // make sure not to read in negative pixel locations Mx := max(min(TrueMax, SourceSize - 1), 0); // make sure not to read past w-1 in the source Contribs[X].High := Mx - Contribs[X].min; Assert(Contribs[X].High >= 0); // High=Number of contributing pixels minus 1 SetLength(Contribs[X].Weights, Contribs[X].High + 1); with Contribs[X] do begin x1 := delta * (min - SourceStart - xCenter); for j := 0 to High do begin x2 := x1 + delta; Weights[j] := round($800 * (AntiFilter(x2) - AntiFilter(x1))); x1 := x2; end; for j := TrueMin - min to -1 do begin // assume the first pixel to be repeated x1 := delta * (min + j - SourceStart - xCenter); x2 := x1 + delta; Weights[0] := Weights[0] + round($800 * (AntiFilter(x2) - AntiFilter(x1))); end; for j := High + 1 to TrueMax - min do begin // assume the last pixel to be repeated x1 := delta * (min + j - SourceStart - xCenter); x2 := x1 + delta; Weights[High] := Weights[High] + round($800 * (AntiFilter(x2) - AntiFilter(x1))); end; end; { with Contribs[x] } end; { for x } end; // This writes one column in the target procedure ProcessColumn(X, ymin, ymax, Sbps, Tbps, NewHeight: integer; rStart, rTStart: PByte; runstart: PBGRAInt; const ContribsX, ContribsY: TContribArray); inline; var ps, pT: PRGBQuad; rs, rT: PByte; y, xs, ys: integer; highx, highy, minx, miny: integer; WeightxStart, Weightx, Weighty: PInteger; Total: TBGRAInt; run: PBGRAInt; begin rs := rStart; highx := ContribsX[X].High; minx := ContribsX[X].min; inc(rs, 4 * minx); WeightxStart := @ContribsX[X].Weights[0]; run := runstart; // runstart points to Columnx[0] // Colmnx stores the result of the resampling in x-direction for y := ymin to ymax do begin // For each source line at y // Sum up weighted color values at source pixels ContribsX[x].Min+xs // 0<=xs<=ContribsX[x].High // and store the results in Columnx[y-ymin] etc. ps := PRGBQuad(rs); Weightx := WeightxStart; FillChar(run^, SizeOf(run^), 0); for xs := 0 to highx do begin inc(run.b, Weightx^ * ps.rgbBlue); inc(run.g, Weightx^ * ps.rgbGreen); inc(run.r, Weightx^ * ps.rgbRed); inc(run.a, Weightx^ * ps.rgbReserved); inc(Weightx); inc(ps); end; inc(run); dec(rs, Sbps); end; // Average in y-direction: // For each target line y sum up weighted colors in // Columnx[ys+ContribsY[y].Min-ymin], 0<=ys<=ContribsY[y].High // Store result in Total // round and assign to TargetPixel pt at [x,y] rT := rTStart; for y := 0 to NewHeight - 1 do begin pT := PRGBQuad(rT); inc(pT, X); highy := ContribsY[y].High; miny := ContribsY[y].min - ymin; Weighty := @ContribsY[y].Weights[0]; run := runstart; inc(run, miny); FillChar(Total, SizeOf(Total), 0); for ys := 0 to highy do begin inc(Total.b, Weighty^ * run.b); inc(Total.g, Weighty^ * run.g); inc(Total.r, Weighty^ * run.r); inc(Total.a, Weighty^ * run.a); inc(Weighty); inc(run); end; Total.r := max(Total.r, 0); Total.g := max(Total.g, 0); Total.b := max(Total.b, 0); Total.a := max(Total.a, 0); // results could be negative, filter has negative values Total.r := (Total.r + $1FFFFF) shr 22; // "round" the result Total.g := (Total.g + $1FFFFF) shr 22; Total.b := (Total.b + $1FFFFF) shr 22; Total.a := (Total.a + $1FFFFF) shr 22; pT.rgbBlue := min(Total.b, 255); pT.rgbGreen := min(Total.g, 255); pT.rgbRed := min(Total.r, 255); pT.rgbReserved := min(Total.a, 255); dec(rT, Tbps); end; // for y end; procedure ZoomResampleParallel(const Source, Target: TBitmap; SourceRect: TRectF; Radius: single); var ContribsX, ContribsY: TContribArray; OldWidth, OldHeight: integer; NewWidth, NewHeight: integer; Sbps, Tbps: integer; rStart, rTStart: PByte; // Row start in Source, Target ymin, ymax, i: integer; tasks: array [0 .. 3] of ITask; Chunk: integer; begin Source.PixelFormat := pf32bit; Target.PixelFormat := pf32bit; // for safety // Target needs to have been set to correct size NewWidth := Target.Width; NewHeight := Target.Height; OldWidth := Source.Width; OldHeight := Source.Height; Tbps := ((NewWidth * 32 + 31) and not 31) div 8; // BytesPerScanline Target Sbps := ((OldWidth * 32 + 31) and not 31) div 8; // BytesPerScanline Source MakeContributors(Radius, OldWidth, NewWidth, SourceRect.Left, SourceRect.Right - SourceRect.Left, ContribsX); MakeContributors(Radius, OldHeight, NewHeight, SourceRect.Top, SourceRect.Bottom - SourceRect.Top, ContribsY); ymin := ContribsY[0].min; ymax := ContribsY[NewHeight - 1].High + ContribsY[NewHeight - 1].min; rStart := Source.ScanLine[ymin]; rTStart := Target.ScanLine[0]; Chunk := NewWidth div 4; // stupid repetion! tasks[0] := TTask.create( procedure begin var Columnx: TBGRAIntArray; // Stores averaged x-Contributors var X, xmin, xmax: integer; var runstart: PBGRAInt; SetLength(Columnx, ymax - ymin + 1); runstart := @Columnx[0]; xmin := 0; xmax := Chunk - 1; for X := xmin to xmax do ProcessColumn(X, ymin, ymax, Sbps, Tbps, NewHeight, rStart, rTStart, runstart, ContribsX, ContribsY); end); tasks[1] := TTask.create( procedure begin var Columnx: TBGRAIntArray; var X, xmin, xmax: integer; var runstart: PBGRAInt; SetLength(Columnx, ymax - ymin + 1); runstart := @Columnx[0]; xmin := Chunk; xmax := 2 * Chunk - 1; for X := xmin to xmax do ProcessColumn(X, ymin, ymax, Sbps, Tbps, NewHeight, rStart, rTStart, runstart, ContribsX, ContribsY); end); tasks[2] := TTask.create( procedure begin var Columnx: TBGRAIntArray; var X, xmin, xmax: integer; var runstart: PBGRAInt; SetLength(Columnx, ymax - ymin + 1); runstart := @Columnx[0]; xmin := 2 * Chunk; xmax := 3 * Chunk - 1; for X := xmin to xmax do ProcessColumn(X, ymin, ymax, Sbps, Tbps, NewHeight, rStart, rTStart, runstart, ContribsX, ContribsY); end); tasks[3] := TTask.create( procedure begin var Columnx: TBGRAIntArray; var X, xmin, xmax: integer; var runstart: PBGRAInt; SetLength(Columnx, ymax - ymin + 1); runstart := @Columnx[0]; xmin := 3 * Chunk; xmax := NewWidth - 1; for X := xmin to xmax do ProcessColumn(X, ymin, ymax, Sbps, Tbps, NewHeight, rStart, rTStart, runstart, ContribsX, ContribsY); end); for i := 0 to 3 do tasks[i].start; if not TTask.WaitForAll(tasks, 10000) then Raise exception.create('Time out for parallel resampling threads'); end; procedure ZoomResample(const Source, Target: TBitmap; SourceRect: TRectF; Radius: single); var ContribsX, ContribsY: TContribArray; OldWidth, OldHeight: integer; NewWidth, NewHeight: integer; // Target needs to be set to correct size Sbps, Tbps: integer; rStart, rTStart: PByte; // Row start in Source, Target Columnx: TBGRAIntArray; // cache array, records for better memory layout X, ymin, ymax: integer; runstart: PBGRAInt; begin Source.PixelFormat := pf32bit; Target.PixelFormat := pf32bit; // for safety NewWidth := Target.Width; NewHeight := Target.Height; OldWidth := Source.Width; OldHeight := Source.Height; Tbps := ((NewWidth * 32 + 31) and not 31) div 8; // BytesPerScanline Target Sbps := ((OldWidth * 32 + 31) and not 31) div 8; // BytesPerScanline Source MakeContributors(Radius, OldWidth, NewWidth, SourceRect.Left, SourceRect.Right - SourceRect.Left, ContribsX); MakeContributors(Radius, OldHeight, NewHeight, SourceRect.Top, SourceRect.Bottom - SourceRect.Top, ContribsY); ymin := ContribsY[0].min; ymax := ContribsY[NewHeight - 1].High + ContribsY[NewHeight - 1].min; rStart := Source.ScanLine[ymin]; rTStart := Target.ScanLine[0]; SetLength(Columnx, ymax - ymin + 1); runstart := @Columnx[0]; // Compute colors for each target column at x for X := 0 to NewWidth - 1 do begin ProcessColumn(X, ymin, ymax, Sbps, Tbps, NewHeight, rStart, rTStart, runstart, ContribsX, ContribsY); end; // for x end; end.

That would be great. Here are some relevant lines of the log file, I doubt they are of any use, though: 2021.04.08 14:23:10.909 #DEBUG #PeFile::Open #PeFile.cpp(111) #Executable (PE) C:\Windows\SysWOW64\ntdll.dll opened 2021.04.08 14:23:10.137 #DEBUG #PeFile::InitializeSymbolEngine #PeFile.cpp(699) #Executable (PE) C:\Windows\SysWOW64\ntdll.dll started Symbol Engine initialization 2021.04.08 14:23:10.752 #DEBUG #PeFile::InitializeSymbolEngine #PeFile.cpp(751) #Executable (PE) C:\Windows\SysWOW64\ntdll.dll initialized Symbol Engine: PDB 2021.04.08 14:23:10.662 #DEBUG #PeFile::Open #PeFile.cpp(111) #Executable (PE) D:\DelphiSource\DelphiRio\mystuffR\uProfTest\Win32\Debug\uProfTest.exe opened 2021.04.08 14:23:10.945 #DEBUG #PeFile::InitializeSymbolEngine #PeFile.cpp(699) #Executable (PE) D:\DelphiSource\DelphiRio\mystuffR\uProfTest\Win32\Debug\uProfTest.exe started Symbol Engine initialization 2021.04.08 14:23:10.113 #DEBUG #PeFile::InitializeSymbolEngine #PeFile.cpp(758) #Executable (PE) D:\DelphiSource\DelphiRio\mystuffR\uProfTest\Win32\Debug\uProfTest.exe failed to initialize Symbol Engine: PDB 2021.04.08 14:23:10.740 #DEBUG #PeFile::InitializeSymbolEngine #PeFile.cpp(778) #Executable (PE) D:\DelphiSource\DelphiRio\mystuffR\uProfTest\Win32\Debug\uProfTest.exe initialized Symbol Engine: COFF

I have tried to make the pdb of a simple console application to work with AMD uProf, but it fails, no matter what I try. But the hotspot feature of VTune works on my AMD system, so I am happy right now. Thanks! Renate

Just a note: Flickering when using styles can almost completely be eliminated by removing seBorder from the form's style elements. But if you prefer to see the buggy styled caption bar, you're out of luck:)

Ok, here is the installable component. The dimming is not tied to visible anymore, but to a property Active, which can only be set at runtime. The control to be dimmed isn't tied to the parent at design time, instead there is a published property DimmedControl, which the parent will be set to at runtime (unless it's nil, then no dimming is possible). At design time the component can be dropped anywhere to design the child controls. DimmedControl can be changed at runtime. The attachment contains packages for runtime and design and a crude demo. I haven't changed aehimself's unit- and class names, which I should have done, but I'm too tired now. I'm using Delphi 10.3.3, it should work for 10.4.*, too. Instructions: Load BuildandDemo.groupproj Build DimPanel.bpl (runtime) for both Win32 and Win64 Build DimPanelD.bpl (design) Install DimPanelD.bpl Open and run DemoDim The component is on the "Additional" tab. If TDimPanel is grayed under Win64, try to close and reopen the IDE. Hope it roughly works 🙂 Edit: Bug in previous attachment The size was not set right initially, has been fixed by an override to Loaded DimPanel.zip

If you drop a component, the owner is always the form. That's one of the things. You could of course always drop it on the control you want to dim, then you've got the parent right. But some things need to be disabled at design time, the VisibleChanging for once. I'm working on something that doesn't blow up in your face, lets you design the child controls, and also allows you to specify a dimmed control other than what you can drop it on at design time ... say, a listbox or a pagecontrol. Much of this works really nicely with your runtime-only version. I want to get this done without having to write a designer. Maybe it's not worth the trouble and placing the controls at runtime is easy enough 🙂

I would remove the Register-procedure for the time being, it needs a quite a few changes to make it play nicely in the IDE, one sore point is e.g. the re-introduced constructor.