fpc/rtl/win32/thread.inc

{
    $Id$
    This file is part of the Free Pascal run time library.
    Copyright (c) 1999-2000 by the Free Pascal development team.

    Multithreading implementation for Win32

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}
const
   threadvarblocksize : dword = 0;

type
   tthreadinfo = record
      f : tthreadfunc;
      p : pointer;
   end;
   pthreadinfo = ^tthreadinfo;

var
   dataindex : dword;

{ import the necessary stuff from windows }
function TlsAlloc : DWord;external 'kernel32' name 'TlsAlloc';
function TlsGetValue(dwTlsIndex : DWord) : pointer;
  external 'kernel32' name 'TlsGetValue';
function TlsSetValue(dwTlsIndex : DWord;lpTlsValue : pointer) : LongBool;
  external 'kernel32' name 'TlsSetValue';
function TlsFree(dwTlsIndex : DWord) : LongBool;
  external 'kernel32' name 'TlsFree';
function CreateThread(lpThreadAttributes : pointer;
  dwStackSize : DWord; lpStartAddress : pointer;lpParameter : pointer;
  dwCreationFlags : DWord;var lpThreadId : DWord) : THandle;
  external 'kernel32' name 'CreateThread';
procedure ExitThread(dwExitCode : DWord);
  external 'kernel32' name 'ExitThread';

procedure init_threadvar(var offset : dword;size : dword);[public,alias: 'FPC_INIT_THREADVAR'];

  begin
     offset:=threadvarblocksize;
     inc(threadvarblocksize,size);
  end;


function relocate_threadvar(offset : dword) : pointer;[public,alias: 'FPC_RELOCATE_THREADVAR'];

  begin
     relocate_threadvar:=TlsGetValue(dataindex)+offset;
  end;

procedure AllocateThreadVars;

  var
     threadvars : pointer;

  begin
     { we've to allocate the memory from windows }
     { because the FPC heap management uses      }
     { exceptions which use threadvars but       }
     { these aren't allocated yet ...            }
     { allocate room on the heap for the thread vars }
     threadvars:=pointer(GlobalAlloc(GMEM_FIXED or GMEM_ZEROINIT,
       threadvarblocksize));
     TlsSetValue(dataindex,threadvars);
  end;

procedure InitThread;

  begin
     InitFPU;
     { we don't need to set the data to 0 because we did this with }
     { the fillchar above, but it looks nicer                      }

     { ExceptAddrStack and ExceptObjectStack are threadvars       }
     { so every thread has its on exception handling capabilities }
     InitExceptions;
     InOutRes:=0;
     ErrNo:=0;
  end;

procedure DoneThread;

  var
     threadvars : pointer;

  begin
     { release thread vars }
     threadvars:=TlsGetValue(dataindex);
     GlobalFree(threadvars);
  end;

function ThreadMain(param : pointer) : dword;stdcall;

  var
     ti : tthreadinfo;

  begin
{$ifdef DEBUG_MT}
     writeln('New thread started, initialising ...');
{$endif DEBUG_MT}
     AllocateThreadVars;
     InitThread;
     ti:=pthreadinfo(param)^;
     dispose(pthreadinfo(param));
{$ifdef DEBUG_MT}
     writeln('Jumping to thread function');
{$endif DEBUG_MT}
     ThreadMain:=ti.f(ti.p);
  end;


function BeginThread(sa : Pointer;stacksize : dword;
  ThreadFunction : tthreadfunc;p : pointer;creationFlags : dword;
  var ThreadId : DWord) : DWord;

  var
     ti : pthreadinfo;

  begin
{$ifdef DEBUG_MT}
     writeln('Creating new thread');
{$endif DEBUG_MT}
     IsMultithreaded:=true;
     { the only way to pass data to the newly created thread }
     { in a MT safe way, is to use the heap                  }
     new(ti);
     ti^.f:=ThreadFunction;
     ti^.p:=p;
{$ifdef DEBUG_MT}
     writeln('Starting new thread');
{$endif DEBUG_MT}
     BeginThread:=CreateThread(sa,stacksize,@ThreadMain,ti,
       creationflags,threadid);
  end;

function BeginThread(ThreadFunction : tthreadfunc) : DWord;

  var
     dummy : dword;

  begin
     BeginThread:=BeginThread(nil,0,ThreadFunction,nil,0,dummy);
  end;

function BeginThread(ThreadFunction : tthreadfunc;p : pointer) : DWord;

  var
     dummy : dword;

  begin
     BeginThread:=BeginThread(nil,0,ThreadFunction,p,0,dummy);
  end;

function BeginThread(ThreadFunction : tthreadfunc;p : pointer;
  var ThreadId : DWord) : DWord;

  begin
     BeginThread:=BeginThread(nil,0,ThreadFunction,p,0,ThreadId);
  end;

procedure EndThread(ExitCode : DWord);

  begin
     DoneThread;
     ExitThread(ExitCode);
  end;

procedure EndThread;

  begin
     EndThread(0);
  end;

{ we implement these procedures for win32 by importing them }
{ directly from windows                                     }

procedure InitCriticalsection(var cs : tcriticalsection);

  begin
  end;

procedure DoneCriticalsection(var cs : tcriticalsection);

  begin
  end;

procedure EnterCriticalsection(var cs : tcriticalsection);

  begin
  end;

procedure LeaveCriticalsection(var cs : tcriticalsection);

  begin
  end;

{
procedure InitCriticalSection(var cs : tcriticalsection);
  external 'kernel32' name 'InitializeCriticalSection';

procedure DoneCriticalSection(var cs : tcriticalsection);
  external 'kernel32' name 'DeleteCriticalSection';

procedure EnterCriticalSection(var cs : tcriticalsection);
  external 'kernel32' name 'EnterCriticalSection';

procedure LeaveCriticalSection(var cs : tcriticalsection);
  external 'kernel32' name 'LeaveCriticalSection';
}
{
  $Log$
  Revision 1.1  2001-01-01 19:06:36  florian
    + initial release

}