binary-trees Free Pascal #6 program

(*
  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;

uses CMem, {$IFDEF UNIX}CThreads,{$ENDIF} PooledMM, PasMP;

type
  TMemPool = PooledMM.TNonFreePooledMemManager;

  TData = array of record
    Depth, Iterations, Check: Int32;
  end;

  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: PtrUInt = 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: PtrUInt;
  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 ', Succ(MaxDepth), #9' check: ',
          TNode.CheckNode(TNode.MakeTree(Succ(MaxDepth), 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.
  SetLength(Data, (MaxDepth - MinDepth) div 2 + 1);
  with TPasMP.CreateGlobalInstance() do
    Invoke(ParallelFor(@Data, 0, High(Data), @TNode.DoTrees));

  // Display the results.
  for I := 0 to High(Data) do with Data[I] do
    WriteLn(IO^, Iterations, #9' trees of depth ', Depth, #9' check: ', Check);

  // Destroy the long lived tree.
  WriteLn(IO^, 'long lived tree of depth ', MaxDepth, #9' check: ', TNode.CheckNode(Tree));
  Pool.Free();
end.
    

NOTES:
64-bit Ubuntu quad core
Free Pascal Compiler
version 3.2.2 [2021/05/16]


 Wed, 22 May 2024 19:04:40 GMT

MAKE:
mv binarytrees.fpascal-6.fpascal binarytrees.fpascal-6.pas
/opt/src/fpc-3.2.2/bin/fpc -FuInclude/fpascal -XXs -O3 -Ci- -Cr- -g- -CpCOREAVX -CfAVX -Tlinux -Mdelphi -oFPASCAL_RUN binarytrees.fpascal-6.pas
Free Pascal Compiler version 3.2.2 [2021/05/16] for x86_64
Copyright (c) 1993-2021 by Florian Klaempfl and others
Target OS: Linux for x86-64
Compiling binarytrees.fpascal-6.pas
binarytrees.fpascal-6.pas(103,5) Note: Call to subroutine "function TPasMP.GetJobWorkerThread:TPasMPJobWorkerThread;" marked as inline is not inlined
binarytrees.fpascal-6.pas(103,5) Note: Call to subroutine "procedure TPasMP.PushJob(const Job:PPasMPJob;const JobWorkerThread:TPasMPJobWorkerThread);" marked as inline is not inlined
Linking FPASCAL_RUN
Warning: "crtbegin.o" not found, this will probably cause a linking failure
Warning: "crtend.o" not found, this will probably cause a linking failure
111 lines compiled, 1.5 sec
2 warning(s) issued
2 note(s) issued
mv FPASCAL_RUN binarytrees.fpascal-6.fpascal_run
rm binarytrees.fpascal-6.pas

1.91s to complete and log all make actions

COMMAND LINE:
 ./binarytrees.fpascal-6.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