{$ifndef fpc}!FREE PASCAL ONLY!{$endif}
{$mode objfpc}
{$longstrings on}
{$coperators on}
{$r+}


//PABO stands for Pointer Addressed Bit Array.
//I.e. an assoative array of bits indexed by pointers.


//This thing is NOT thread-safe!

{$ifdef i386}
  {$define asm_allowed}
  {$asmmode intel}
{$endif}

{$ifdef cpux86_64}
  {$define asm_allowed}
  {$asmmode intel}
{$endif}

unit un_pabo;

interface
  uses sysutils, math;

type
  TPaboSegment = record
    base: ptrint;
    data: array of ptruint;
    fshrinkcount: ptrint; //for lazy downsizing
  end;

const
  PaboDefaultGranularity = 4;
  (*
    granularity is power of two of the basic alignment in bytes.
    default memory manager does have 16 bytes, that's granularity of 4.
    Any pointer passed to PABO will be silently rounded down to 16-bytes boundary
    If you have to work with more densely packed pointers (e.g. to array elements)
    then pass a lower value to the constructor (e.g. 2 for 32-bit alignment).

    If you are absolutely sure you're using a custom memory manager with larger
    granularity, then you can pass a larger value.

    If you are unsure - don't touch it.
  *)


  //in bytes!
  PaboDefaultSegmentLimit = {$ifdef go32v2} 16 * 1024 {$else} 128 * 4096 {$endif};



type
  TPABO = class
  protected
    Segments: array of TPaboSegment;
    granularity: dword;
    segmentLimit: ptrint;
    fdontshrink: boolean;
    function AccomodateSegment(v: ptrint): integer;
    function _GetMarked(p: pointer) : boolean;
    function GetMarked(ind: integer; v: ptrint): boolean;
    procedure SetMarked(ind: integer; v: ptrint);
    procedure SetCleared(ind: integer; v: ptrint);
    function FindSegment(v: ptrint) : integer;
    function FindClosestSegment(v: ptrint): integer;
    procedure ShrinkSegment(ind: integer);
  public
    constructor Create(
      OverrideSegmentLimit: ptrint = PaboDefaultSegmentLimit;
      Overrideranularity: dword = PaboDefaultGranularity
    );
    destructor Destroy; override;
    procedure Mark(p: pointer; b: boolean = true);
    procedure Clear(p: pointer);
    property Marked[p: pointer]: boolean read _GetMarked write Mark; default;
    property DontShrink: boolean read fdontshrink write  fdontshrink ;
  end;


implementation
  const
    {$ifdef cpu32}
    pishift = 5;
    lowbitsmask = $1f;
    {$endif}
    {$ifdef cpu64}
    pishift = 6;
    lowbitsmask = $3f;
    {$endif}

    //Because there's a f***ng dedicated instruction for this in every CPU since 80386.
    // But does Free Pascal support the bit scan operation on the language level? Noooo.
    //Result is capped at 19
    {$ifdef asm_allowed}
      //it's guaranteed to be non-NIL at this point!
      function GetPointerGranularity(p:pointer): ptruint; assembler; register;
      asm
       {$ifdef i386}
        bsf p, eax
       {$endif}
       {$ifdef cpux86_64}
        bsf p, rax
       {$endif}
      end;
    {$else}
      function GetPointerGranularity(p:pointer): ptruint;
      begin
        Result:= 0;
        while (Result < 19 //maximum one megabyte!
          ) and ((ptruint(p) shr (Result and 1)) = 1) do Inc(Result);
      end;
    {$endif}

  constructor TPABO.Create(
    OverrideSegmentLimit: ptrint = PaboDefaultSegmentLimit;
    Overrideranularity: dword = PaboDefaultGranularity
  );
  begin
    inherited Create;
    granularity:= Overrideranularity;
    segmentLimit:= OverrideSegmentLimit;
  end;


  function TPABO._GetMarked(p: pointer) : boolean;
  var
    si: integer;
    v: ptrint;
  begin
    if not Assigned(p) then Exit(false);
    v:= ptrint(ptruint(p) shr granularity);
    si:= FindSegment(v);
    if (si >= 0) then Result:= GetMarked(si, v) else Result:= false;
  end;

  function TPABO.FindSegment(v: ptrint) : integer;
  var
    i: integer;
  begin
    for i:=0 to High(Segments) do
      with Segments[i] do
        if (v >= base) and (v < base + (length(data) shl pishift))
          then Exit(i);
    Result:= -1;
  end;

  procedure TPABO.Mark(p: pointer; b: boolean);
  var
    i: integer;
    v: ptrint;
  begin
    Assert(not b or Assigned(p), 'TPABO.Mark: the pointer is NIL!');
    if not Assigned(p) then Exit;
    v:= ptrint(ptruint(p) shr granularity);
    i:= FindSegment(v);
    if i < 0 then begin
      if not b then Exit; //do not expand segments on clearing non-existent bit
      i:= AccomodateSegment(v);
    end;
    if b then SetMarked(i, v) else SetCleared(i, v);
  end;

  procedure TPABO.Clear(p: pointer);
  var
    i: integer;
    v: ptrint;
  begin
    if not Assigned(p) then Exit;
    v:= ptrint(ptruint(p) shr granularity) ;
    i:= FindSegment(v);
    if i < 0 then Exit;
    SetCleared(i, v);
  end;


  function TPABO.GetMarked(ind: integer; v: ptrint): boolean;
  begin
    with Segments[ind] do begin
      v-= base;
      Result:= (data[v shr pishift] and (ptruint(1) shl (v and lowbitsmask))) > 0;
    end;
  end;



  procedure TPABO.SetMarked(ind: integer; v: ptrint);
  begin
    with Segments[ind] do begin
//Write('SetMarked: v=',v,'  base=',base, ' of #',ind);
      v-= base;
//WriteLn ( '  ...  v=', v, '  vs ', (Length(data) shl pishift) - 1);
      data[v shr pishift]:= data[v shr pishift] or (ptruint(1) shl (v and lowbitsmask));
    end;
  end;

  procedure TPABO.SetCleared(ind: integer; v: ptrint);
  begin
    with Segments[ind] do begin
      v-= base;
      data[v shr pishift]:= data[v shr pishift] and not (ptruint(1) shl (v and lowbitsmask));
      if not fdontshrink then begin
        Dec(fshrinkcount);
        fshrinkcount:= max(0, min(1000, fshrinkcount));
        if fshrinkcount = 0 then ShrinkSegment(ind);
      end;
    end;
  end;


  destructor TPABO.Destroy;
  var
    i: integer;
  begin
    for i:= 0 to High(Segments) do SetLength(Segments[i].Data, 0);
    SetLength(Segments, 0);
    inherited;
  end;

//TODO: support merging adjacent segments!
  function TPABO.AccomodateSegment(v: ptrint): integer;
  var
    closest: integer;
    hplus, bplus, oldhigh, i: integer;
    newbase: ptrint;
  begin
    closest:= FindClosestSegment(v);
    if closest >= 0 then with segments[closest] do begin
//WriteLn('Accomodating ', v, ' for #', closest,'(', base, ',', length(data) shl pishift, ')');
      if (v < base) then  begin
        newbase:= (v shr pishift) shl pishift;
        bplus:= (base - newbase) shr pishift;
        hplus:= 0;
      end else begin
        newbase:= base;
        bplus:= 0;
        if ((v - base) shr pishift) > high(data) then begin
          hplus:= ((v - base) shr pishift) - high(data);
        end else begin
          hplus:= 0;
        end;
      end;
      oldhigh:= high(data);
      SetLength(data, Length(data) + bplus + hplus);
      if bplus > 0 then begin
        base:= newbase;
        for i:= oldhigh downto 0 do data[i + bplus]:= data[i];
        for i:= 0 to bplus - 1 do data[i]:= 0;
      end;
      for i:= oldhigh + bplus + 1 to high(data) do data[i]:= 0;
//WriteLn('    enlarged segment ' + intToStr(bplus) + ' / ' + intToStr(hplus));
      Result:= closest;
      fshrinkcount+= hplus + bplus;
    end
    else begin
      //there's no close segment, creating a new one
      SetLength(Segments, Length(Segments) + 1);
      with Segments[High(Segments)] do begin
        //base is always aligned so that the bit mask consists of even number of ptruints
        base:= (v shr pishift) shl pishift;
        SetLength(data, 1);
        data[0]:= 0;
      end;
      Result:= High(Segments);
    end;
  end;

  function TPABO.FindClosestSegment(v: ptrint): integer;
  var
    i: integer;
    diff, d: ptrint;
  begin
    Result:= -1;
    diff:= segmentLimit shr granularity;
    for i:= 0 to High(Segments) do
      With Segments[i] do begin
        if (v < base)
          then  d:= base - v
          else  d:= v - (base + (length(data) shl pishift));
        d+= length(data) shl pishift;  //prefer to expand shorter ones
        if d  < diff
        then begin
          diff:= d;
          Result:= i;
        end;
      end;
  end;


  procedure TPABO.ShrinkSegment(ind: integer);
  var
    nh, nb, i: integer;
  begin
    with segments[ind] do begin
      nb:=0;
      while (nb < length(data)) and (data[nb] = 0) do Inc(nb);
      if nb > high(data) then begin
        //It's empty! delete all data
        SetLength(data, 0);
      end
      else begin
        nh:= high(data);
        while (nh > nb) and (data[nh] = 0) do Dec(nh);
        if (nb > 0) then begin
          //base increases. Shift the data
          base+= nb * 8 * sizeof(pointer);
          for i:= nb to nh do data[i - nb]:= data[i];
        end;
        fshrinkcount+= nh;
        SetLength(data, nh - nb + 1);
      end;
      if length(data) = 0 then begin
        //deleting this segment;
        for i:= ind to high(segments) - 1 do segments[i]:= segments[i + 1];
        setlength(segments, length(segments) - 1);
      end;
    end;
  end;





end.

