Transactions in cache

It was really difficult to find the following bug in ChessKISS,  the bug was that under certain conditions the engine played really silly moves

Best scores from at any depth are stored in the transposition table, so far so good, however once you must re-enter the iterative deepening loop due to some aspiration window issue, all entries stored in that Alpha-Beta window should be somehow discarded, otherwise the engine may use those wrong entries. After some tests I end up with this idea, which is to behave as a Database, that's it, StartTransaction, Commit or Rollback:

TEntry = record
  public
    Key: integer;
    History: cardinal;
    //PackedInfo: 16 upper bits = (Score), 16 lower bits = (8 upper bits = HashType) & (8 lower bits = depth)
    PackedInfo: integer;
    Move: TMove;
    Transaction: integer; //This is the current transaction
    //Align 32
    Align: array[0..11] of byte;

    procedure Clear; inline;
  end;
  PEntry = ^TEntry;

  TTransactionStatus = (tsNone, tsInProgress, tsOk, tsCancel);

type
  TCluster = array[0..3] of TEntry;

  TTranspositionTable = class
  private
    FData: array of TCluster;
    FHistory: cardinal;
    FCount: integer;
    FSize: cardinal;
    FTransactions: array[0..16383] of TTransactionStatus;
    FTransactionCount: integer;
    FWrites: integer;

    function IsDiscarded(aEntry: PEntry): boolean; inline;
    function GetEntry(aKey: int64): PEntry; inline;
    function GetBucket(aKey: integer): integer; inline;
    function GetKey(aKey: int64): integer; inline;
    function Pack(aDepth, aScore: integer; aHashType: THashType): integer; inline;
    procedure Unpack(aValue: integer; out aDepth, aScore: integer; out aHashType: THashType); inline;
    function UnpackDepth(aValue: integer): integer; inline;
  public
    constructor Create(aSize: cardinal);
    procedure Add(aKey: int64; aMove: TMove; aDepth, aScore: integer; aHashType: THashType);
    procedure AddScore(aKey: int64; aScore: integer);
    procedure Clear;
    procedure Commit;
    procedure RollBack;
    function Get(aKey: int64; out aMove: TMove; out aDepth, aScore: integer; out aHashType: THashType): boolean;
    function GetScore(aKey: int64; out aScore: integer): boolean;
    function GetMove(aKey: int64; out aMove: TMove): boolean;
    procedure StartTransaction;
    procedure TimeGoesBy; inline;

    property Count: integer read FCount;
    property Size: cardinal read FSize;
  end;

This is the implementation:

{ TTranspositionTable }

procedure TTranspositionTable.Add(aKey: int64; aMove: TMove; aDepth, aScore: integer; aHashType: THashType);
var
  new: TEntry;
  entry, replace: PEntry;
  key,
  i, c1, c2, c3: integer;
  available, discarded: boolean;

begin
  Inc(FWrites);
  key := GetKey(aKey);

  new.Key := key;
  new.History := FHistory;
  new.PackedInfo := Pack(aDepth, aScore, aHashType);
  new.Move := aMove;
  new.Transaction := FTransactionCount;

  entry := GetEntry(aKey);
  replace := entry;

  //discarded := False;
  i := High(TCluster);
  while i >= 0 do
  begin
    //Empty, same key or discarded
    discarded := False;
    available := (entry.Key = 0) or (entry.Key = key);
    if not available then
      discarded := IsDiscarded(entry);

    if available or discarded then
    begin
      //Keep old move if no move
      //if (aMove = NO_MOVE) and (available) then
      //  new.Move := entry.Move;

      entry^ := new;
      Exit;
    end;

    //Replace policy
    if replace.History = FHistory then
      c1 := 2
    else
      c1 := 0;

    if entry.History = FHistory then
      c2 := -2
    else
      c2 := 0;

    if UnpackDepth(entry.PackedInfo) < UnpackDepth(replace.PackedInfo) then
      c3 := 1
    else
      c3 := 0;

    if c1 + c2 + c3 > 0 then
      replace := entry;

    Inc(entry);
    Dec(i);
  end;

  //Replace (cluster full)
  replace^ := new;
end;

procedure TTranspositionTable.AddScore(aKey: int64; aScore: integer);
var
  new: TEntry;
  entry: PEntry;
  key, i: integer;

begin
  key := GetKey(aKey);
  entry := GetEntry(aKey);

  i := High(TCluster);
  while i >= 0 do
  begin
    if entry.Key = 0 then
    begin
      new.Key := key;
      new.PackedInfo := aScore;
      entry^ := new;

      Exit;
    end;

    Inc(entry);
    Dec(i);
  end;
end;

procedure TTranspositionTable.Clear;
var
  i, j: integer;

begin
  for i := 0 to Length(FData) - 1 do
  begin
    for j := Low(TCluster) to High(TCluster) do
      FData[i][j].Clear;
  end;

  FHistory := 0;
  FTransactionCount := 0;
  for i := Low(FTransactions) to High(FTransactions) do
    FTransactions[i] := tsNone;
end;

procedure TTranspositionTable.Commit;
begin
  FTransactions[FTransactionCount] := tsOk;
end;

constructor TTranspositionTable.Create(aSize: cardinal);
begin
  //Must be power of 2!
  FSize := 1024;
  while FSize * 2 * SizeOf(TCluster) <= aSize do
    FSize := FSize * 2;

  SetLength(FData, FSize);
  FCount := Length(FData);

  Clear;
end;

function TTranspositionTable.IsDiscarded(aEntry: PEntry): boolean;
begin
  Exit(FTransactions[FTransactionCount] = tsCancel);
end;

procedure TTranspositionTable.RollBack;
begin
  FTransactions[FTransactionCount] := tsCancel;
end;

procedure TTranspositionTable.StartTransaction;
begin
  Inc(FTransactionCount);
  FTransactions[FTransactionCount] := tsInProgress;
end;

function TTranspositionTable.Get(aKey: int64; out aMove: TMove; out aDepth, aScore: integer; out aHashType: THashType): boolean;
var
  i: integer;
  entry: PEntry;
  key: integer;

begin
  key := GetKey(aKey);
  entry := GetEntry(aKey);

  i := High(TCluster);
  while i >= 0 do
  begin
    if (entry.Key = key) and (not IsDiscarded(entry)) then
    begin
      aMove := entry.Move;
      Unpack(entry.PackedInfo, aDepth, aScore, aHashType);

      Exit(True);
    end;

    Inc(entry);
    Dec(i);
  end;

  aMove := 0;
  aDepth := 0;
  aScore := 0;

  Exit(False);
end;

function TTranspositionTable.GetEntry(aKey: int64): PEntry;
begin
  Exit(@FData[GetBucket(integer(aKey))][0]);  //Use the low 32 bits as index
end;

function TTranspositionTable.GetKey(aKey: int64): integer;
begin
  Exit(aKey shr 32);  //Use the high 32 bits as key
end;

procedure TTranspositionTable.TimeGoesBy;
begin
  Inc(FHistory);
  FWrites := 0;
end;

function TTranspositionTable.GetMove(aKey: int64; out aMove: TMove): boolean;
var
  i: integer;
  entry: PEntry;
  key: integer;

begin
  key := GetKey(aKey);
  entry := GetEntry(aKey);

  i := High(TCluster);
  while i >= 0 do
  begin
    if entry.Key = key then
    begin
      aMove := entry.Move;
      Exit(True);
    end;

    Inc(entry);
    Dec(i);
  end;

  Exit(False);
end;

function TTranspositionTable.GetScore(aKey: int64; out aScore: integer): boolean;
var
  entry: PEntry;
  key, i: integer;

begin
  key := GetKey(aKey);
  entry := GetEntry(aKey);

  i := High(TCluster);
  while i >= 0 do
  begin
    if entry.Key = key then
    begin
      aScore := entry.PackedInfo;
      Exit(True);
    end;

    Inc(entry);
    Dec(i);
  end;

  aScore := 0;
  Exit(False);
end;

function TTranspositionTable.GetBucket(aKey: integer): integer;
begin
  Exit(aKey and (FCount - 1));
end;

function TTranspositionTable.Pack(aDepth, aScore: integer; aHashType: THashType): integer;
begin
  Exit(aScore * 65536 + Ord(aHashType) shl 8 + aDepth);
end;

procedure TTranspositionTable.Unpack(aValue: integer; out aDepth, aScore: integer; out aHashType: THashType);
begin
  aScore := integer(aValue and $ffff0000) div 65536; //Needs sign, so no SHR!
  aDepth := aValue and $ff;
  aHashType := THashType(aValue and $ffffff00 shr 8);
end;

function TTranspositionTable.UnpackDepth(aValue: integer): integer;
begin
  Exit(aValue and $ff);
end;
So the idea is, for every call to StartTransaction() increment the counter of transactions, for the current one (always the last one) set the Status (FTransactions array) to tsInProgress, now all entries are stored using the current transaction number, now we have to possibilities, to commit or to rollback:
Commit) Set to OK the flag from the current transaction
Rollback) Set to NOOK the flag from the current transaction
Now Add() and Get() call a new function IsDiscarded(), this functions returns True if that transaction is cancelled (rollback), otherwise false.
So imagine we have added 1.000.000 entries in the last loop, it would be very slow and also memory consuming to track the entries on a list, like this is only a metter of a flag, for the class in an entry is discarded is like is available and can be used and overwrited.
And finally how do I use it (in bold red):
function TSearch.IterativeDeepening: TMove;
var
  scores: array[0..MAX_DEPTH - 1] of integer;
  miss, i, CurrentScore, MateIn: integer;
  line: TString;
  time, start, TimeThreshold: cardinal;
  WasTimeOut: boolean;
  score, pv: TString;

begin
  //Make a new search history
  FCache.TimeGoesBy;
  FEvaluation.TimeGoesBy;

  FBestMove := NO_MOVE;
  FMissed := 0;
  miss := 0;
  FAlpha := -INFINITE;
  FBeta := INFINITE;
  i := 1;
  TimeThreshold := Round(FTimeForMove * 0.90);
  start := GetTickCount;

  repeat
    IterativeClean;
    FCache.StartTransaction;

    FCurrentMaxDepth := i;
    scores[i] := AlphaBeta(FAlpha, FBeta, i, True);
    //scores[i] := Root(FAlpha, FBeta, i);
    CurrentScore := scores[i];

    //If we miss the aspiration window, make a new search with full window on the side that missed
    if FAspirationWindow then
    begin
      if (CurrentScore <= FAlpha) or (CurrentScore >= FBeta) then
      begin
        //Data stored in TT from the current iteration is not valid
        FCache.RollBack;

        Inc(miss);
        if miss <= 3 then
        begin
          FAlpha := Max(FAlpha - FAspirationWindowSize, -INFINITE);
          FBeta := Min(FBeta + FAspirationWindowSize, INFINITE);
          Continue;
        end;
        miss := 0;

        if CurrentScore <= FAlpha then
        begin
          FAlpha := -INFINITE;
          Inc(FMissed);

          Continue;
        end;

        if CurrentScore >= FBeta then
        begin
          FBeta := INFINITE;
          Inc(FMissed);

          Continue;
        end;
      end;
    end;

    //Commit data in TT
    FCache.Commit;

    WasTimeOut := IsTimeOut;
    if (not WasTimeOut) and (not FCancel) then
    begin
      time := GetTickCount - start;

      pv := GetPV(MateIn);
      if MateIn <> 0 then
      begin
        if MateIn < 0 then
          score := '-M' + IntToStr(Abs(MateIn))
        else
          score := '+M' + IntToStr(Abs(MateIn));
      end else
        score := IntToStr(CurrentScore);

      line := IntToStr(i) + ' ' + score + ' ' + IntToStr(time) + ' ' + IntToStr(FCounter) + ' ' + pv;
      start := GetTickCount;
      if Assigned(FOnSearch) then
        FOnSearch(line);
    end;

    if WasTimeOut then //No more time...
    begin
      if FBestMove <> NO_MOVE then
        Break
      else
      begin
        NeedMoreTime; //Could not make a move, let's add some time
        Continue;
      end;
    end;

    //If the score while deepining dropped by at least the value of a pawn something bad can happend
    if (i > 2) and
       (scores[i - 1] - scores[i] >= PieceValues[ptPawn]) and
       (scores[i - 2] - scores[i - 1] >= PieceValues[ptPawn]) then
      NeedMoreTime;

    //Get ready for a new search, with a new window
    if FAspirationWindow then
    begin     
      FAlpha := CurrentScore - FAspirationWindowSize;
      if FAlpha <= -INFINITE then
        FAlpha := -INFINITE;

      FBeta := CurrentScore + FAspirationWindowSize;
      if FBeta >= INFINITE then
        FBeta := INFINITE;
    end;

    //If we used 90% of the time so far, then break
    if (FSearchType = stPerTime) and (GetTickCount - start > TimeThreshold) then
      Break;

    //If we have reach the proposed depth, then break
    Inc(i);
    if (FSearchType = stPerDepth) and (i > FDepth) then
      Break;

  until i > MAX_DEPTH;

  Exit(FBestMove);
end;
Maybe is a totally silly idea..., but for me it works