{%MainUnit system.pp} // In nanoseconds Type // We use an alias here. TWasmMutex = TRTLCriticalSection; TMutexKind = (mkNormal,mkRecursive); TLockMutexResult = (lmrNone,lmrOK,lmrNotOwner,lmrError,lmrTimeout); Function MutexKind(const M : TWasmMutex) : TMutexKind; begin Result:=TMutexKind(M.Kind); end; procedure InitMutex(var M : TWasmMutex; aKind : TMutexKind = mkNormal; aOwner : TThreadID = Nil); begin FillChar(M,SizeOf(TWasmMutex),0); if aOwner=Nil then aOwner:=GetSelfThread; M.Creator:=aOwner; M.Kind:=Ord(aKind); fpc_wasm32_i32_atomic_store(@M.Owner,0); fpc_wasm32_i32_atomic_store(@M.Locked,0); end; procedure DoneMutex(var M : TWasmMutex); Var a : LongInt; begin if (fpc_wasm32_i32_atomic_load(@M.Locked)<>0) and (M.Creator=GetSelfThread) then begin M.Destroying:=True; a:=fpc_wasm32_memory_atomic_notify(@M.Locked,MaxThreadSignal); end; end; Function TryLockMutex(var M : TWasmMutex) : Boolean; Var Res : Boolean; begin // We already have the lock ? Res:=(fpc_wasm32_i32_atomic_load(@M.Locked)=1) and (TThreadID(fpc_wasm32_i32_atomic_load(@M.Owner))=GetSelfThread); if Not Res then Res:=fpc_wasm32_i32_atomic_rmw_cmpxchg_u(@M.Locked,0,1)=0 else begin // TryLockMutex is called in a loop. Be VERY careful when adding this log. // {$IFDEF DEBUGWASMTHREADS}DebugWriteln('TryLockMutex : we ('+IntToStr(PtrUint(GetSelfThread))+') own the lock.');{$ENDIF} end; if Res then begin if (MutexKind(M)=mkRecursive) or (M.Count=0) then InterLockedIncrement(M.Count); // {$IFDEF DEBUGWASMTHREADS}DebugWriteln('TryLockMutex : setting owner to '+IntToStr(PtrUint(GetSelfThread))+'.');{$ENDIF} fpc_wasm32_i32_atomic_store(@M.Owner,LongWord(GetSelfThread)); end; TryLockMutex:=Res; end; // aTimeOutNS is in nanoseconds. <0 (e.g. -1) is infinite Function LockMutexTimeoutNoWait(var m : TWasmMutex; aTimeOutNS : Int64) : TLockMutexResult; Var Res : TLockMutexResult; EndTime: TOSTime; begin {$IFDEF DEBUGWASMTHREADS}DebugWriteln('LockMutexTimeoutNoWait('+IntToStr(m.locked)+','+intToStr(aTimeOutNS)+')');{$ENDIF} Res:=lmrNone; if aTimeOutNS>=0 then EndTime:=GetClockTime+aTimeOutNS else EndTime:=0; {$IFDEF DEBUGWASMTHREADS}DebugWriteln('LockMutexTimeoutNoWait: entering loop');{$ENDIF} Repeat if TryLockMutex(M) then Res:=lmrOK else if (aTimeOutNS>=0) and (GetClockTime>EndTime) then Res:=lmrTimeOut; Until (res<>lmrNone); {$IFDEF DEBUGWASMTHREADS}DebugWriteln('LockMutexTimeoutNoWait: done loop');{$ENDIF} LockMutexTimeoutNoWait:=Res; end; Function LockMutexTimeoutWait(var m : TWasmMutex; aTimeOutNS : Int64) : TLockMutexResult; Var Res : TLockMutexResult; EndTime: TOSTime; RemainingTime: Int64; begin {$IFDEF DEBUGWASMTHREADS}DebugWriteln('LockMutexTimeoutWait('+IntToStr(m.locked)+','+intToStr(aTimeOutNS)+')');{$ENDIF} Res:=lmrNone; if aTimeOutNS>=0 then EndTime:=GetClockTime+aTimeOutNS else begin EndTime:=0; RemainingTime:=-1; end; InterLockedIncrement(M.Waiters); {$IFDEF DEBUGWASMTHREADS}DebugWriteln('LockMutexTimeoutWait: entering loop');{$ENDIF} Repeat if TryLockMutex(m) then Res:=lmrOk else begin if aTimeOutNS>=0 then begin RemainingTime:=EndTime-GetClockTime; if RemainingTime<0 then Res:=lmrTimeOut;; end; if Res<>lmrNone then Case fpc_wasm32_memory_atomic_wait32(@M.Locked,1,RemainingTime) of 0, 1: if M.Destroying then Res:=lmrError; 2: if M.Destroying then Res:=lmrError else Res:=lmrTimeOut; end; end; Until Res<>lmrNone; {$IFDEF DEBUGWASMTHREADS}DebugWriteln('LockMutexTimeoutWait: done loop');{$ENDIF} InterLockedDecrement(M.Waiters); LockMutexTimeoutWait:=Res; end; Function LockMutexTimeout(var m : TWasmMutex; aTimeOutNS : Int64) : TLockMutexResult; begin if TryLockMutex(M) then Result:=lmrOK else if isWaitAllowed then Result:=LockMutexTimeoutWait(m,aTimeOutNS) else Result:=LockMutexTimeoutNoWait(m,aTimeOutNS) end; Function LockMutex(var m : TRTLCriticalSection) : TLockMutexResult; begin LockMutexTimeout(M,-1); end; function UnLockMutex(var m : TRTLCriticalSection) : TLockMutexResult; var Res : TLockMutexResult; MyThread : TThreadID; EndTime: TOSTime; a : LongInt; begin Res:=lmrNone; MyThread:=GetSelfThread; if MyThread<>TThreadID(fpc_wasm32_i32_atomic_load(@M.Owner)) then Res:=lmrNotOwner else if M.Count=0 then Res:=lmrError else begin res:=lmrOK; if (MutexKind(M)=mkRecursive) or (M.Count=1) then InterLockedDecrement(M.Count); if (M.Count=0) then begin fpc_wasm32_i32_atomic_store(@M.Owner,0); fpc_wasm32_i32_atomic_store(@M.Locked,0); a:=fpc_wasm32_memory_atomic_notify(@M.Locked,1); end; end; end;