source code
(*
The Computer Language Benchmarks Game
https://salsa.debian.org/benchmarksgame-team/benchmarksgame/
- contributed by Vitaly Trifonof based on a contribution of Ales Katona
- made multi-threaded by Nitorami, February 2018:
https://forum.lazarus.freepascal.org/index.php?topic=39935.0
- additionally modified by Akira1364, March/April 2019
*)
program BinaryTrees;
{$PointerMath On}
uses CMem, {$IFDEF UNIX}CThreads,{$ENDIF} PooledMM, PasMP;
type
TMemPool = PooledMM.TNonFreePooledMemManager;
PDataRec = ^TDataRec;
TDataRec = record
Depth: Byte;
Iterations, Check: Int32;
end;
TData = array[0..8] of TDataRec;
PNode = ^TNode;
TNode = record
Left, Right: PNode;
class function CheckNode(const ANode: PNode): Int32; static; inline;
class function MakeTree(const Depth: Int32; const MP: TMemPool): PNode; static; inline;
class procedure DoTrees(const Job: PPasMPJob;
const ThreadIndex: Int32;
const UserData: Pointer;
const FromIndex, ToIndex: PtrInt); static; inline;
end;
// Simplified recursive check.
class function TNode.CheckNode(const ANode: PNode): Int32;
begin
with ANode^ do if (Right <> nil) and (Left <> nil) then
Exit(1 + CheckNode(Right) + CheckNode(Left));
Result := 1;
end;
// Make a tree recursively.
class function TNode.MakeTree(const Depth: Int32; const MP: TMemPool): PNode;
begin
Result := MP.NewItem();
with Result^ do begin Right := nil; Left := nil; end;
if Depth > 0 then with Result^ do begin
Right := MakeTree(Pred(Depth), MP);
Left := MakeTree(Pred(Depth), MP);
end;
end;
const
MinDepth = 4;
MaxDepth: Byte = 10;
// Make multiple trees.
class procedure TNode.DoTrees(const Job: PPasMPJob;
const ThreadIndex: Int32;
const UserData: Pointer;
const FromIndex, ToIndex: PtrInt);
var
I: Int32;
IPool: TMemPool;
begin
with TData(UserData^)[FromIndex] do begin
Depth := MinDepth + FromIndex * 2;
Iterations := 1 shl (MaxDepth - FromIndex * 2);
Check := 0;
IPool := TMemPool.Create(SizeOf(TNode));
for I := 1 to Iterations do begin
Check += CheckNode(MakeTree(Depth, IPool));
IPool.Clear();
end;
IPool.Free();
end;
end;
var
I, HighIndex: Byte;
P: PDataRec;
IO: PText;
Tree: PNode;
Pool: TMemPool;
Data: TData;
begin
IO := @Output;
if ParamCount = 1 then Val(ParamStr(1), MaxDepth);
if MaxDepth < MinDepth + 2 then MaxDepth := MinDepth + 2;
// Create and destroy a tree of depth MaxDepth + 1.
Pool := TMemPool.Create(SizeOf(TNode));
WriteLn(IO^, 'stretch tree of depth ', MaxDepth + 1, #9' check: ',
TNode.CheckNode(TNode.MakeTree(MaxDepth + 1, Pool)));
Pool.Clear();
// Create a "long lived" tree of depth MaxDepth.
Tree := TNode.MakeTree(MaxDepth, Pool);
// While the tree stays live, create multiple trees. Local data is stored in the "Data" variable.
HighIndex := (MaxDepth - MinDepth) div 2;
with TPasMP.CreateGlobalInstance() do
Invoke(ParallelFor(@Data, 0, HighIndex, @TNode.DoTrees));
// Display the results, using pointer arithmetic only because this is a benchmark so we actually care about
// about things at the millisecond level.
P := @Data[0];
for I := 0 to HighIndex do begin
WriteLn(IO^, P^.Iterations, #9' trees of depth ', P^.Depth, #9' check: ', P^.Check);
Inc(P);
end;
// Destroy the long lived tree.
WriteLn(IO^, 'long lived tree of depth ', MaxDepth, #9' check: ', TNode.CheckNode(Tree));
Pool.Free();
end.
notes, command-line, and program output
NOTES:
64-bit Ubuntu quad core
Free Pascal Compiler version 3.2.0 [2020/06/14] for x86_64
Sat, 20 Jun 2020 17:28:09 GMT
MAKE:
mv binarytrees.fpascal-7.fpascal binarytrees.fpascal-7.pas
/opt/src/fpc-3.2.0/bin/fpc -FuInclude/fpascal -XXs -O3 -Ci- -Cr- -g- -CpCOREI -Tlinux -Mdelphi -oFPASCAL_RUN binarytrees.fpascal-7.pas
Free Pascal Compiler version 3.2.0 [2020/06/14] for x86_64
Copyright (c) 1993-2020 by Florian Klaempfl and others
Target OS: Linux for x86-64
Compiling binarytrees.fpascal-7.pas
Compiling ./Include/fpascal/PasMP.pas
PasMP.pas(553,36) Warning: range check error while evaluating constants (-2147483649 must be between 0 and 4294967295)
PasMP.pas(3641,2) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(5476,2) Note: Call to subroutine "procedure ReadBarrier;" marked as inline is not inlined
PasMP.pas(5492,2) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(5503,2) Note: Call to subroutine "procedure WriteBarrier;" marked as inline is not inlined
PasMP.pas(5514,2) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(5554,2) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(7729,3) Note: Call to subroutine "procedure ReadBarrier;" marked as inline is not inlined
PasMP.pas(7731,3) Note: Call to subroutine "procedure ReadBarrier;" marked as inline is not inlined
PasMP.pas(7864,2) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(7873,2) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(8620,2) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(8627,2) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(8660,2) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(8672,6) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(9010,3) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(9062,4) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(9116,4) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(9173,3) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(9225,4) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(9279,4) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(9369,3) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(9399,3) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(10865,3) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(10905,2) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(10933,2) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(11341,8) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(11399,4) Note: Call to subroutine "procedure TPasMP.ExecuteJob(const Job:PPasMPJob;const JobWorkerThread:TPasMPJobWorkerThread);" marked as inline is not inlined
PasMP.pas(11434,2) Note: Call to subroutine "procedure TPasMP.Run(const Job:PPasMPJob);" marked as inline is not inlined
PasMP.pas(11841,2) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(11852,5) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(12386,10) Note: Call to subroutine "function TPasMP.GetThreadIDHash(ThreadID:QWord):DWord; Static;" marked as inline is not inlined
PasMP.pas(12386,10) Note: Call to subroutine "function TPasMPThreadSafeStack.Pop:^untyped;" marked as inline is not inlined
PasMP.pas(12391,10) Note: Call to subroutine "function TPasMP.GetThreadIDHash(ThreadID:QWord):DWord; Static;" marked as inline is not inlined
PasMP.pas(12391,10) Note: Call to subroutine "function TPasMPThreadSafeStack.Pop:^untyped;" marked as inline is not inlined
PasMP.pas(12396,10) Note: Call to subroutine "function TPasMP.GetThreadIDHash(ThreadID:QWord):DWord; Static;" marked as inline is not inlined
PasMP.pas(12396,10) Note: Call to subroutine "function TPasMPThreadSafeStack.Pop:^untyped;" marked as inline is not inlined
PasMP.pas(12452,3) Note: Call to subroutine "procedure TPasMP.Run(const Job:PPasMPJob);" marked as inline is not inlined
PasMP.pas(12476,6) Note: Call to subroutine "procedure TPasMP.ExecuteJob(const Job:PPasMPJob;const JobWorkerThread:TPasMPJobWorkerThread);" marked as inline is not inlined
PasMP.pas(12518,4) Note: Call to subroutine "procedure TPasMP.Run(const Job:PPasMPJob);" marked as inline is not inlined
PasMP.pas(12571,5) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(12585,3) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(12599,4) Note: Call to subroutine "procedure ReadWriteBarrier;" marked as inline is not inlined
PasMP.pas(12618,6) Note: Call to subroutine "procedure TPasMP.ExecuteJobTask(const Job:PPasMPJob;const JobWorkerThread:TPasMPJobWorkerThread;const ThreadIndex:LongInt);" marked as inline is not inlined
PasMP.pas(12660,7) Note: Call to subroutine "procedure TPasMP.ExecuteJobTask(const Job:PPasMPJob;const JobWorkerThread:TPasMPJobWorkerThread;const ThreadIndex:LongInt);" marked as inline is not inlined
PasMP.pas(12680,3) Note: Call to subroutine "function TPasMP.GetThreadIDHash(ThreadID:QWord):DWord; Static;" marked as inline is not inlined
PasMP.pas(12680,3) Note: Call to subroutine "procedure TPasMP.PushJob(const Job:PPasMPJob;const JobWorkerThread:TPasMPJobWorkerThread);" marked as inline is not inlined
PasMP.pas(12708,3) Note: Call to subroutine "function TPasMP.GetThreadIDHash(ThreadID:QWord):DWord; Static;" marked as inline is not inlined
PasMP.pas(12708,3) Note: Call to subroutine "procedure TPasMP.PushJob(const Job:PPasMPJob;const JobWorkerThread:TPasMPJobWorkerThread);" marked as inline is not inlined
PasMP.pas(12723,2) Note: Call to subroutine "function TPasMP.GetJobWorkerThread:TPasMPJobWorkerThread;" marked as inline is not inlined
PasMP.pas(12723,2) Note: Call to subroutine "procedure TPasMP.PushJob(const Job:PPasMPJob;const JobWorkerThread:TPasMPJobWorkerThread);" marked as inline is not inlined
PasMP.pas(12978,5) Note: Call to subroutine "function TPasMP.GetThreadIDHash(ThreadID:QWord):DWord; Static;" marked as inline is not inlined
PasMP.pas(12978,5) Note: Call to subroutine "procedure TPasMP.PushJob(const Job:PPasMPJob;const JobWorkerThread:TPasMPJobWorkerThread);" marked as inline is not inlined
PasMP.pas(13037,5) Note: Call to subroutine "function TPasMP.GetThreadIDHash(ThreadID:QWord):DWord; Static;" marked as inline is not inlined
PasMP.pas(13037,5) Note: Call to subroutine "procedure TPasMP.PushJob(const Job:PPasMPJob;const JobWorkerThread:TPasMPJobWorkerThread);" marked as inline is not inlined
PasMP.pas(13691,3) Note: Call to subroutine "function TPasMP.GetJobWorkerThread:TPasMPJobWorkerThread;" marked as inline is not inlined
PasMP.pas(13691,3) Note: Call to subroutine "procedure TPasMP.PushJob(const Job:PPasMPJob;const JobWorkerThread:TPasMPJobWorkerThread);" marked as inline is not inlined
PasMP.pas(13909,3) Note: Call to subroutine "function TPasMP.GetJobWorkerThread:TPasMPJobWorkerThread;" marked as inline is not inlined
PasMP.pas(13909,3) Note: Call to subroutine "procedure TPasMP.PushJob(const Job:PPasMPJob;const JobWorkerThread:TPasMPJobWorkerThread);" marked as inline is not inlined
binarytrees.fpascal-7.pas(111,5) Note: Call to subroutine "function TPasMP.GetJobWorkerThread:TPasMPJobWorkerThread;" marked as inline is not inlined
binarytrees.fpascal-7.pas(111,5) Note: Call to subroutine "procedure TPasMP.PushJob(const Job:PPasMPJob;const JobWorkerThread:TPasMPJobWorkerThread);" marked as inline is not inlined
Linking FPASCAL_RUN
14082 lines compiled, 1.3 sec
1 warning(s) issued
60 note(s) issued
mv FPASCAL_RUN binarytrees.fpascal-7.fpascal_run
rm binarytrees.fpascal-7.pas
1.33s to complete and log all make actions
COMMAND LINE:
./binarytrees.fpascal-7.fpascal_run 21
PROGRAM OUTPUT:
stretch tree of depth 22 check: 8388607
2097152 trees of depth 4 check: 65011712
524288 trees of depth 6 check: 66584576
131072 trees of depth 8 check: 66977792
32768 trees of depth 10 check: 67076096
8192 trees of depth 12 check: 67100672
2048 trees of depth 14 check: 67106816
512 trees of depth 16 check: 67108352
128 trees of depth 18 check: 67108736
32 trees of depth 20 check: 67108832
long lived tree of depth 21 check: 4194303