From a0aaa69c0f50809026ef3bd1fc04bc9fd2b54878 Mon Sep 17 00:00:00 2001 From: marcus Date: Mon, 14 Aug 2017 19:52:16 +0000 Subject: [PATCH] Amicommon: implemented BasicEvents in AThreads git-svn-id: trunk@36905 - --- rtl/amicommon/athreads.pp | 296 +++++++++++++++++++++++++++++++++++++- 1 file changed, 294 insertions(+), 2 deletions(-) diff --git a/rtl/amicommon/athreads.pp b/rtl/amicommon/athreads.pp index f90888718e..b0600ac04a 100644 --- a/rtl/amicommon/athreads.pp +++ b/rtl/amicommon/athreads.pp @@ -46,6 +46,7 @@ var SubThreadBaseName: String = 'FPC Subthread'; {.$define DEBUG_MT} +{.$define DEBUG_AMIEVENT} type TThreadOperation = ( toNone, toStart, toResume, toExit ); @@ -408,7 +409,7 @@ begin WaitPort(@thisThread^.pr_MsgPort); threadMsg:=PThreadMsg(GetMsg(@thisThread^.pr_MsgPort)); - { fetch existing threadinfo from the start message, and set + { fetch existing threadinfo from the start message, and set it to tc_userData, so we can proceed with threadvars } threadInfo:=threadMsg^.tm_ThreadInfo; thisThread^.pr_Task.tc_userData:=threadInfo; @@ -831,27 +832,318 @@ begin end; +// Event Stuff + +// Return values for WaitFor +const + wrSignaled = 0; + wrTimeout = 1; + wrAbandoned = 2; + wrError = 3; + +// the internal AmigaEvent +type + TAmiEvent = record + IsSet: Boolean; // the actual Event setting + Manual: Boolean; // do not automatically reset the event + Name: string; // Name for the event structure (needed for cross process) + Waiter: Integer; // number of WaitFor waiting for this event + Destroyed: Boolean; // the event is going to be destroyed, all WaitFor please leave first + Sem: TSignalSemaphore; // Semaphore to protect the whole stuff + end; + PAmiEvent = ^TAmiEvent; + +// Create an Event function intBasicEventCreate(EventAttributes : Pointer; AManualReset,InitialState : Boolean;const Name : ansistring):pEventState; +var + AmiEvent: PAmiEvent; begin + New(AmiEvent); + AmiEvent^.isSet := InitialState; + AmiEvent^.Name := Name; + AmiEvent^.Waiter := 0; + AmiEvent^.Manual := AManualReset; + AmiEvent^.Destroyed := False; + InitSemaphore(@AmiEvent^.Sem); + Result := AmiEvent; end; procedure intbasiceventdestroy(state:peventstate); +var + AmiEvent: PAmiEvent absolute State; + Waiter: Integer; begin + if Assigned(AmiEvent) then + begin + ObtainSemaphore(@AmiEvent^.Sem); + AmiEvent^.Destroyed := True; // we destroy the event + ReleaseSemaphore(@AmiEvent^.Sem); + repeat + DosDelay(1); + until AmiEvent^.Waiter <= 0; + ObtainSemaphore(@AmiEvent^.Sem); // is there anyone still waiting for it? + ReleaseSemaphore(@AmiEvent^.Sem); + Dispose(AmiEvent); + end; end; procedure intbasiceventResetEvent(state:peventstate); +var + AmiEvent: PAmiEvent absolute State; begin + if Assigned(AmiEvent) then + begin + {$IFDEF DEBUG_AMIEVENT} + SysDebugLn('AmiEvent: Reset Event'); + {$ENDIF} + ObtainSemaphore(@AmiEvent^.Sem); + AmiEvent^.IsSet := False; + ReleaseSemaphore(@AmiEvent^.Sem); + end; end; procedure intbasiceventSetEvent(state:peventstate); +var + AmiEvent: PAmiEvent absolute State; begin + if Assigned(AmiEvent) then + begin + {$IFDEF DEBUG_AMIEVENT} + SysDebugLn('AmiEvent: Set Event'); + {$ENDIF} + ObtainSemaphore(@AmiEvent^.Sem); + AmiEvent^.IsSet := True; + ReleaseSemaphore(@AmiEvent^.Sem); + end; end; -function intbasiceventWaitFor(Timeout : Cardinal;state:peventstate) : longint; +// Timer stuff +procedure NewList(List: PList); inline; begin + with List^ do + begin + lh_Head := PNode(@lh_Tail); + lh_Tail := nil; + lh_TailPred := PNode(@lh_Head) + end; end; +function CreatePort(Name: PChar; Pri: LongInt): PMsgPort; +var + SigBit: ShortInt; + Port: PMsgPort; +begin + Sigbit := AllocSignal(-1); + if sigbit = -1 then + CreatePort := nil; + Port := ExecAllocMem(SizeOf(TMsgPort), MEMF_CLEAR); + if Port = nil then + begin + FreeSignal(SigBit); + CreatePort := nil; + end; + with port^ do + begin + if Assigned(Name) then + mp_Node.ln_Name := Name + else + mp_Node.ln_Name := nil; + mp_Node.ln_Pri := pri; + mp_Node.ln_Type := 4; + mp_Flags := 0; + mp_SigBit := SigBit; + mp_SigTask := FindTask(nil); + end; + if Assigned(Name) then + AddPort(Port) + else + NewList(Addr(Port^.mp_MsgList)); + CreatePort := Port; +end; + +procedure DeletePort(Port: PMsgPort); +begin + if port <> nil then + begin + if Port^.mp_Node.ln_Name <> nil then + RemPort(Port); + + Port^.mp_Node.ln_Type := $FF; + Port^.mp_MsgList.lh_Head := PNode(-1); + FreeSignal(Port^.mp_SigBit); + ExecFreeMem(Port, SizeOf(TMsgPort)); + end; +end; + +function CreateExtIO(Port: PMsgPort; Size: LongInt): PIORequest; +begin + Result := nil; + if Port <> nil then + begin + Result := ExecAllocMem(Size, MEMF_CLEAR); + if Result <> nil then + begin + Result^.io_Message.mn_Node.ln_Type := 7; + Result^.io_Message.mn_Length := Size; + Result^.io_Message.mn_ReplyPort := Port; + end; + end; +end; + +procedure DeleteExtIO (IoReq: PIORequest); +begin + if IoReq <> nil then + begin + IoReq^.io_Message.mn_Node.ln_Type := $FF; + IoReq^.io_Message.mn_ReplyPort := PMsgPort(-1); + IoReq^.io_Device := PDevice(-1); + ExecFreeMem(IoReq, IoReq^.io_Message.mn_Length); + end +end; + +function Create_Timer(TheUnit: LongInt): PTimeRequest; +var + TimerPort: PMsgPort; +begin + Result := nil; + TimerPort := CreatePort(nil, 0); + if TimerPort = nil then + Exit; + Result := PTimeRequest(CreateExtIO(TimerPort, SizeOf(TTimeRequest))); + if Result = Nil then + begin + DeletePort(TimerPort); + Exit; + end; + if OpenDevice(TIMERNAME, TheUnit, PIORequest(Result), 0) <> 0 then + begin + DeleteExtIO(PIORequest(Result)); + DeletePort(TimerPort); + Result := nil; + end; +end; + +Procedure Delete_Timer(WhichTimer: PTimeRequest); +var + WhichPort: PMsgPort; +begin + WhichPort := WhichTimer^.tr_Node.io_Message.mn_ReplyPort; + if assigned(WhichTimer) then + begin + CloseDevice(PIORequest(WhichTimer)); + DeleteExtIO(PIORequest(WhichTimer)); + end; + if Assigned(WhichPort) then + DeletePort(WhichPort); +end; + +function GetEventTime(TR: PTimeRequest): Int64; +begin + Result := -1; + if tr = nil then + Exit; + tr^.tr_node.io_Command := TR_GETSYSTIME; + DoIO(PIORequest(tr)); + // structure assignment + Result := Int64(tr^.tr_time.TV_Secs) * 1000 + tr^.tr_time.TV_Micro div 1000; +end; +// End timer stuff + +// the mighty Waitfor routine +function intbasiceventWaitFor(Timeout : Cardinal;state:peventstate) : longint; +var + AmiEvent: PAmiEvent absolute State; + Tr: PTimeRequest = nil; + StartTime, CurTime: Int64; +begin + {$IFDEF DEBUG_AMIEVENT} + SysDebugLn('AmiEvent: Enter WaitFor'); + {$ENDIF} + Result := wrError; + if Assigned(AmiEvent) then + begin + // we do an initial Check + ObtainSemaphore(@AmiEvent^.Sem); + if AmiEvent^.Destroyed then + begin + Result := wrAbandoned; // we got destroyed, so we just leave + {$IFDEF DEBUG_AMIEVENT} + SysDebugLn('AmiEvent: WaitFor Early Destroy'); + {$ENDIF} + Exit; + end; + if AmiEvent^.IsSet then + begin + Result := wrSignaled; // signal Already set + if not AmiEvent^.Manual then + AmiEvent^.IsSet := False; + {$IFDEF DEBUG_AMIEVENT} + SysDebugLn('AmiEvent: WaitFor Early Signaled'); + {$ENDIF} + Exit; + end; + // signal not set, so we add this call to the waiterlist + Inc(AmiEvent^.Waiter); + ReleaseSemaphore(@AmiEvent^.Sem); + // that means we have to wait and care about the timeout -> need a timer + Tr := create_timer(UNIT_MICROHZ); + if not Assigned(Tr) then // cannot create timer :-O + Exit; + // time we started the actual waiting + StartTime := GetEventTime(TR); + try + // the main loop, notice the breaks are inside the Obtain/Release + // therefore the finally block must release it, (and no other exit allowed!) + repeat + CurTime := GetEventTime(TR); // to check the timeout, outside obtain/release to save some time + ObtainSemaphore(@AmiEvent^.Sem); + // check the status of event + if AmiEvent^.Destroyed then + begin + Result := wrAbandoned; // we got destroyed + {$IFDEF DEBUG_AMIEVENT} + SysDebugLn('AmiEvent: WaitFor Destroy'); + {$ENDIF} + break; + end; + if AmiEvent^.IsSet then + begin + Result := wrSignaled; // signal got set + {$IFDEF DEBUG_AMIEVENT} + SysDebugLn('AmiEvent: WaitFor Signaled'); + {$ENDIF} + Break; + end; + if CurTime - StartTime > Timeout then + begin + Result := wrTimeOut; // we got a timeout + {$IFDEF DEBUG_AMIEVENT} + SysDebugLn('AmiEvent: WaitFor TimeOut'); + {$ENDIF} + Break; + end; + // if we reach here, nothing happend... + // we release the semaphore and wait for other threads to do something + ReleaseSemaphore(@AmiEvent^.Sem); + DosDelay(1); + until False; + finally + // reset the Event if needed + if (Result = wrSignaled) and (not AmiEvent^.Manual) then + AmiEvent^.IsSet := False; + // we finished so get us away from waiter list + Dec(AmiEvent^.Waiter); + ReleaseSemaphore(@AmiEvent^.Sem); // unlock the event + Delete_timer(tr); // timer not needed anymore + end; + end; + {$IFDEF DEBUG_AMIEVENT} + SysDebugLn('AmiEvent: Leave WaitFor'); + {$ENDIF} +end; +// end Event stuff + function AInitThreads : Boolean; begin