unit USynchronization;
// Сделать удаление критических секций
// Вынести GetPage и NextPage в модуль памяти.

interface

uses SysSupport, UMemoryManager, UMemoryMap;

type
  TMutex=DWord;
  PMutex=^TMutex;
const
  MLocked:TMutex=1;
  MUnLocked:TMutex=0;
type
  PCriticalSection=^TCriticalSection;
  TCriticalSection=packed record
  Addr:Pointer;
  Lock:TMutex;
  SubCode:packed record
            Code1:array [0..1] of byte;
            SelfNode:PCriticalSection;
            Code2:array [0..0] of byte;
            CiSBegin:Pointer;
            Code3:array [0..0] of byte;
            end;
  end;
var
  CriticalSectionsList:record
    Lock:TMutex;
    PagesCount:integer;
    HeadPage:Pointer;
    StartPage:Pointer;
    Length:Integer;
    end;

procedure MutexInit(const Mutex:PMutex;const Value:TMutex);
function  MutexTryDoLock(const Mutex:PMutex):Boolean;
procedure MutexDoLock(const Mutex:PMutex);
procedure MutexDoUnLock(const Mutex:PMutex);
procedure SpinMutexDoLock(const Mutex:PMutex);

procedure AtomicAdd32(const Addr:PDword; const Value:DWord);
procedure AtomicSub32(const Addr:PDword; const Value:DWord);
function  AtomicCompareExchange32(const Addr:PDword;const CmpValue:DWord; const NewValue:Dword):Boolean;

// Критическая секция
procedure CiSBegin(var CriticalSection:PCriticalSection); far;
procedure CiSBeginImp(var CriticalSection:PCriticalSection); far;
procedure CiSEnd(const CriticalSection:PCriticalSection); far;

//procedure SpliceBegin;

const
  CriticalSectionNil:TCriticalSection
     =(Addr:nil; Lock:0; SubCode:(
       Code1:($C7, $00); SelfNode:Nil;      // Mov [EAX], Nil
       Code2:($E8); CiSBegin:@CiSBeginImp;  // Call CiSBeginImp
       Code3:($C3)                          // ret
       ));

implementation


procedure CriticalSectionNew(var CriticalSection:PCriticalSection;const Addr:Pointer); Forward;

procedure MutexInit(const Mutex:PMutex;const Value:TMutex);
assembler;
asm
  MOV edx, Value
  MOV DWord PTR [Mutex], edx
end;

function MutexTryDoLock(const Mutex:PMutex):Boolean;
assembler;
asm
  MOV   edx, 1 
  XCHG [mutex],edx
  OR    edx, edx
  SETZ  al
end;

procedure MutexDoLock(const Mutex:PMutex);
assembler;
asm
  MOV  edx, 1
  MOV  DWord PTR [mutex],edx
end;

procedure MutexDoUnLock(const Mutex:PMutex);
assembler;
asm
  MOV  edx,0
  MOV  DWord PTR [mutex],edx
end;

procedure SpinMutexDoLock(const Mutex:PMutex);
assembler;
asm
@spin_loop:
  MOV   edx,1
  lock  XCHG  DWord PTR [mutex],edx
  OR    edx,edx
  JZ    @lock_success
  wait
  JMP   @spin_loop
@lock_success:
end;

procedure AtomicAdd32(const Addr:PDword; const Value:DWord);
assembler;
asm
  MOV  edx, Value
  Lock ADD [Addr],edx
end;

procedure AtomicSub32(const Addr:PDword; const Value:DWord);
assembler;
asm
  MOV  edx, Value
  Lock SUB [Addr],edx
end;

function AtomicCompareExchange32(const Addr:PDword;const CmpValue:DWord; const NewValue:Dword):Boolean;
assembler;
asm
  PUSH  esi
  LEA   esi, [Addr]
  MOV   eax, CmpValue
  MOV   edx, NewValue
  DB 0F0h,00Fh, 0B1h, 016h// lock  CMPXCHG [esi], edx
  SETZ  al
  POP   esi
end;

procedure CiSBegin(var CriticalSection:PCriticalSection);
assembler;
asm
  mov  edx,[esp] // Caller Addr
  SUB  edx, 5
  push eax
  Call CriticalSectionNew
  pop  eax
  Call CiSBeginImp
end;

function  CriticalSectionCreate(const Addr:Pointer):TCriticalSection;
begin
  Result:=CriticalSectionNil;
  Result.Addr:=Addr;
  MutexDoUnLock(@Result.Lock);
end;

procedure CriticalSectionNew(var CriticalSection:PCriticalSection;const Addr:Pointer);
  function LengthToPages(Length:integer):Integer;
    Const ItemSize=SizeOf(TCriticalSection);
    const  PageSize_Pointer=PageSize-SizeOf(Pointer);
  begin
    result:=(Length*ItemSize+PageSize_Pointer-1) div PageSize_Pointer;
  end;
  function IndexModPage(Index:Integer):Integer;
    Const ItemSize=SizeOf(TCriticalSection);
    const ItemsPerPage=(PageSize-SizeOf(Pointer)) div ItemSize;
  begin
    Result:=Index mod ItemsPerPage;
  end;
  function IndexDivPage(Index:Integer):Integer;
    Const ItemSize=SizeOf(TCriticalSection);
    const ItemsPerPage=(PageSize-SizeOf(Pointer)) div ItemSize;
  begin
    Result:=Index Div ItemsPerPage;
  end;

  function GetItem(Index:Integer):PCriticalSection;
  var
    PageIndex, SubIndex:Integer;
    PageChain:PPageChain;
    I:Integer;
  begin
  if Index>=CriticalSectionsList.Length then
     begin
     Result:=Nil;
     Exit;
     end;
  PageIndex:=IndexDivPage(Index);
  SubIndex:=IndexModPage(Index);
  PageChain:=CriticalSectionsList.StartPage;
  for i:=0 to PageIndex-1 do
    PageChain:=PageChain.NextPage;
  Result:=PCriticalSection(PageChain);
  Inc(Result,SubIndex);
  end;

  function GetPage(const Value:Pointer):Pointer;
  begin
    Result:=Pointer((DWord(Value) div PageSize) * PageSize);
  end;

  function NextPage(const Value:Pointer):Pointer;
  var PageChain:PPageChain;
  begin
  PageChain:=GetPage(Value);
  Result:=PageChain.NextPage;
  end;

  function NextItem(CriticalSection:PCriticalSection):PCriticalSection;
  var
    SubAddr:DWord;
    Page:Pointer;
  begin
    If CriticalSection=Nil then
       begin
       Result:=Nil;
       Exit;
       end;
    Result:=CriticalSection;
    Inc(Result);
    SubAddr:=DWord(Result) mod PageSize;
    if (SubAddr>=SizeOf(TPageChainData)) then
       begin
       Page:=GetPage(Result);
       Page:=NextPage(Page);
       If Page=Nil then
          Result:=Nil
          else
          Result:=PCriticalSection(Page);
       end;
  end;

  procedure AddPage;
  var
    PageChain:PPageChain;
    NewPage:Pointer;
  begin
	{$ifdef windows}
    NewPage:=VirtualAlloc(Nil,4096,MEM_COMMIT+MEM_RESERVE,PAGE_EXECUTE_READWRITE);
    {$else}
    NewPage:=PagesStackAlloc(1);
	VirualAllocate(NewPage, 4096, vaCommit, PageFlagsSysRW);
	{$endif}
	PPageChain(NewPage).NextPage:=Nil;
    PageChain:=CriticalSectionsList.HeadPage;
    if  PageChain<>Nil then
        begin
          PageChain.NextPage:=NewPage;
        end else
        begin
          CriticalSectionsList.StartPage:=NewPage;
        end;
    CriticalSectionsList.HeadPage:=NewPage;
    Inc(CriticalSectionsList.PagesCount);
  end;
  // Ищим в списке критическую секцию с заданным адресом.
  // Если нашили то в CriticalSection будет ссылка иначе nil
  function FindAddr(var CriticalSection:PCriticalSection; Addr:Pointer):Boolean;
  var I:Integer;
  begin
  Result:=False;
  CriticalSection:=CriticalSectionsList.StartPage;
  for i:=0 to CriticalSectionsList.Length-1 do
    begin
    if CriticalSection.Addr=Addr then
       begin
       Result:=True;
       exit;
       end;
    NextItem(CriticalSection);
    end;
  CriticalSection:=Nil;
  end;
  procedure PathCode(Addr:Pointer; SubCode:Pointer);
 // var OldProtect:DWord;
  const
    CallOpcod=$E8;
  begin
//  VirtualProtect(Addr, 5, PAGE_EXECUTE_READWRITE, OldProtect);
  if PByte(Addr)^=CallOpcod then
     begin
     Inc(PByte(Addr));
     AtomicCompareExchange32(PDword(Addr), DWord(@CiSBegin)-Dword(Addr)-4, DWord(SubCode)-Dword(Addr)-4);
     end;
  end;
  procedure Registri(var CriticalSection:PCriticalSection);
  var NewLength:Integer;
  begin
  with CriticalSectionsList do
    begin
    NewLength:=Length+1;
    if LengthToPages(NewLength)>PagesCount then
       AddPage;
    Length:=NewLength;
    CriticalSection:=GetItem(Length-1);
    CriticalSection^:=CriticalSectionCreate(Addr);
    CriticalSection^.SubCode.SelfNode:=CriticalSection;
    CriticalSection^.SubCode.CiSBegin:=Pointer(DWord(CriticalSection^.SubCode.CiSBegin)-DWord(@CriticalSection^.SubCode.Code3));
    end;
  end;
begin
  SpinMutexDoLock(@CriticalSectionsList.Lock);
  // Не успели пропатчить, а ядра уже скопились в выше стоящем мьюткса
  // Проверяем зарегистрирована ли критическая секция или ещё нет.
  // Если нет то регистрируем и патчим иначе
  // в CriticalSection - будет правильная ссылка, и мы смело снимаем мьютекс
  // и выходим.
  if Not FindAddr(CriticalSection, Addr) then
     begin
      Registri(CriticalSection);
      PathCode(Addr, @CriticalSection.SubCode);
     end;
  MutexDoUnLock(@CriticalSectionsList.Lock);
end;

// CriticalSection должен указывать на уникальную запись для каждого вызова
// CriticalSectionBeginImp
procedure CiSBeginImp(var CriticalSection:PCriticalSection);
begin
 SpinMutexDoLock(@CriticalSection.Lock);
end;

procedure CiSEnd(const CriticalSection:PCriticalSection);
begin
  MutexDoUnLock(@CriticalSection.Lock);
end;

{
procedure SpliceBegin;
assembler;
asm
mov   [eax], 00000000h
call  CiSBeginImp
end;

procedure SpliceEnd;
assembler;
asm
ret
end;
}

begin
with CriticalSectionsList do
  begin
  PagesCount:=0;
  HeadPage:=Nil;
  StartPage:=Nil;
  Length:=0;
  end;
end.