Source file: /~heha/hs/thread.zip/THREADS.PAS

{Kooperatives Multithreading unter Turbo Pascal und DOS}
{(c) haftmann#software Chemnitz 1996}

{$A+,B-,D+,E-,F-,G-,I-,L+,N-,O-,P-,Q-,R-,S-,T-,V-,X+}
unit threads;

interface

const
 RTE_Thread=220;	{Laufzeitfehler-Code dieser Unit}

type
 PThread=^TThread;
 TThread=record		{Thread-"Deskriptor" (ähnlich wie TSS)}
  next: PThread;	{Nächster der Einfach Verketteten (Ring-)Liste (EVL)}
  stack: Pointer;	{Stackbereich von GetMem für FreeMem}
  case integer of
  1: (_sp,_ss: Word);	{Speicher für SS und SP - mehr ist gar nicht nötig!}
  2: (sssp: Pointer);
 end;

var
 FirstThread: TThread;	{Hauptprogramm; das Feld "stack" ist ungültig}
 CurThread: PThread;	{Zeiger auf "Deskriptor" des lfd. Threads}

function CreateThread(Entry:Pointer; Param:LongInt; Stacksize:Word):PThread;
{Einen neuen Thread erzeugen. Entry zeigt auf eine globale, FAR-codierte
Prozedur mit höchstens einem Argument mit max. 4 Bytes Größe, z.B.
kein Arg, Char, Integer, LongInt, Pointer, PChar. Der Übergabeparameter
ist Param, der ggf. zu auf LongInt zu typecasten ist. Auf diese Weise
kann ein und dieselbe Thread-Prozedur mehrfach gestartet werden. Der
Parameter Stacksize gibt die Größe des Stacks in Bytes an. Er wird auf
dem Heap angelegt. Achtung: Vermutlich funktioniert mit dieser Unit
die Stackprüfung ($S) innerhalb der Threads nicht mehr!}

procedure Yield; far;
{Zum nächsten Thread schalten. Muß aufgrund der Kooperativität gelegentlich -
möglichst häufig - aufgerufen bzw. eingebaut werden. Zerstört in üblicher
Pascal-Manier alle Register außer CS:IP,SS:SP,DS und BP. DS muß wie immer
in Pascal aufs Datensegment zeigen}

procedure _Yield; far;
{Zum nächsten Thread schalten, ohne BP zu retten. Für die Erweiterung zum
präemptiven Multitasking oder zur Rettung weiterer Register vorgesehene
Funktion. Nicht geeignet für Aufruf in gewöhnlichen Pascal-Programmen}

procedure KillThread(Thread:PThread);
{Löscht den angegebenen Thread. Darf nicht der aktuelle Thread und nicht
FirstThread (das Hauptprogramm) sein, sonst Laufzeitfehler!}

procedure KillCurThread;
{Löscht den momentan laufenden Thread. Darf nicht im Hauptprogramm gerufen
werden, sonst Laufzeitfehler! "Voreilige" Alternative zum Beenden des Threads
mit dem Beenden der Threadprozedur selbst}

implementation

procedure _Yield; assembler;	{Zum nächsten Thread schalten}
{Alle Register außer DS,CS,IP,SS,SP werden zerstört}
{DS muß - wie immer in Pascal - ins Standard-Datensegment zeigen}
 asm
  les di,[CurThread]
  mov es:TThread [di]._ss,ss	{Stackzeiger retten}
  mov es:TThread [di]._sp,sp
  les di,es:TThread [di].next	{Nächster Thread}
  mov word [CurThread],di	{Neuer aktueller Thread}
  mov word [CurThread+2],es
  mov ss,es:TThread [di]._ss	{Stackzeiger setzen}
  mov sp,es:TThread [di]._sp
 end;				{springt zum Thread oder zu "pop bp"}

procedure Yield; assembler;	{Zum nächsten Thread schalten}
{BP wird zusätzlich gerettet - Pascal-freundlich}
 asm
  push bp
  call _Yield
  pop bp
 end;

function CreateThread(Entry:Pointer; Param:LongInt; Stacksize:Word):PThread;
 var
  P: PThread;
  SP: Pointer;	{Stack-Ersatzzeiger}
 begin
{Ende der verketteten Liste suchen}
  P:=@FirstThread;
  while P^.next<>@FirstThread do P:=P^.next;
  New(P^.next);		{Neuen EVL-Knoten erzeugen}
  P:=P^.next;		{Diesen adressieren}
  P^.next:=@FirstThread;{Nächster Knoten ist der Anfang}
  GetMem(SP,StackSize);	{Stack-Speicher anfordern}
  P^.stack:=SP;
  Word(SP^):=StackSize;	{Stack-Größe zur Freigabe vorn vermerken}
  Inc(PChar(SP),Stacksize);	{ans Stack-Speicher-Ende}
  Dec(PChar(SP),sizeof(LongInt));
  LongInt(SP^):=Param;		{Simulate_Push Argument}
  Dec(PChar(SP),sizeof(Pointer));
  Pointer(SP^):=@KillCurThread;	{Simulate_Push Return-CS:IP}
  Dec(PChar(SP),sizeof(Pointer));
  Pointer(SP^):=Entry;		{Simulate_Push CS:IP}
  P^.sssp:=SP;			{Thread-Stackspitze abspeichern}
  CreateThread:=P;
 end;

procedure ThreadError;
 begin
  RunError(RTE_Thread);
 end;

function GetPrevThread(Thread:PThread):PThread;
 var
  P:PThread;
 begin
  P:=@FirstThread;
  repeat
   if P^.next=nil then ThreadError;		{Thread-Zeigerfehler}
   if P^.next=@FirstThread then ThreadError;	{Ende der Liste}
   if P^.next=Thread then break;
   P:=P^.next;
  until false;
  GetPrevThread:=P;
 end;

procedure KillThread(Thread:PThread);
 begin
  if Thread=CurThread then ThreadError;		{Nicht für laufenden Thread!}
  if Thread=@FirstThread then ThreadError;	{Nicht für Hauptprogramm}
  GetPrevThread(Thread)^.next:=Thread^.next;	{Aktuellen Thread aushängen}
  FreeMem(Thread^.stack,Word(Thread^.stack^));	{Speicher freigeben}
  Dispose(Thread);				{EVL-Knoten freigeben}
 end;

procedure KillCurThread; assembler;
 asm
  les bx,[CurThread]		{Retten des Stackpointers kann entfallen}
  mov cx,es			{Zeiger retten (nicht auf dem Stack!)}
  les di,es:TThread [bx].next	{Nächster Thread}
  mov word [CurThread],di	{Neuer aktueller Thread}
  mov word [CurThread+2],es
  mov ss,es:TThread [di]._ss	{Stackzeiger setzen}
  mov sp,es:TThread [di]._sp
  push cx
  push bx			{Thread, nun nicht mehr CurThread!}
  call KillThread
 end;

{Initialisierungsteil}
begin
 FirstThread.next:=@FirstThread;{das Hauptprogramm allein}
 CurThread:=@FirstThread;	{Momentan läuft nur dieses}
end.