paweld/pas2js
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/pas2js.git synced 2025-04-07 08:47:49 +02:00
Code Issues Packages Projects Releases Wiki Activity

* WebAssembly thread support

Browse Source
This commit is contained in:
Michaël Van Canneyt 2022-09-07 21:06:10 +02:00
parent 84546ce58c
commit b8cf8a6274
15 changed files with 3423 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
demo/wasienv/threads/bulma.min.css vendored Normal file
View File

File diff suppressed because one or more lines are too long

103
demo/wasienv/threads/demothreads.lpi Normal file
View File

@ -0,0 +1,103 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="12"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
<MainUnitHasScaledStatement Value="False"/>
<Runnable Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<Title Value="WASI Threads Demo"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<CustomData Count="3">
<Item0 Name="MaintainHTML" Value="1"/>
<Item1 Name="Pas2JSProject" Value="1"/>
<Item2 Name="PasJSWebBrowserProject" Value="1"/>
</CustomData>
<BuildModes>
<Item Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
</RunParams>
<Units>
<Unit>
<Filename Value="demothreads.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="demowasithreads"/>
</Unit>
<Unit>
<Filename Value="index.html"/>
<IsPartOfProject Value="True"/>
<CustomData Count="1">
<Item0 Name="PasJSIsProjectHTMLFile" Value="1"/>
</CustomData>
</Unit>
<Unit>
<Filename Value="../../../packages/rtl/rtl.webthreads.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="Rtl.WebThreads"/>
</Unit>
<Unit>
<Filename Value="../../../packages/wasi/wasiworkerthreadhost.pas"/>
<IsPartOfProject Value="True"/>
</Unit>
<Unit>
<Filename Value="../../../packages/wasi/wasithreadedapp.pas"/>
<IsPartOfProject Value="True"/>
</Unit>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target FileExt=".js">
<Filename Value="demothreads"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="js"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<AllowLabel Value="False"/>
<CPPInline Value="False"/>
<UseAnsiStrings Value="False"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<TargetOS Value="browser"/>
</CodeGeneration>
<Linking>
<Debugging>
<GenerateDebugInfo Value="False"/>
<UseLineInfoUnit Value="False"/>
</Debugging>
</Linking>
<Other>
<CustomOptions Value="-Jeutf-8 -Jirtl.js -Jc -Jminclude"/>
<CompilerPath Value="$(pas2js)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions>
<Item>
<Name Value="EAbort"/>
</Item>
<Item>
<Name Value="ECodetoolError"/>
</Item>
<Item>
<Name Value="EFOpenError"/>
</Item>
</Exceptions>
</Debugging>
</CONFIG>

73
demo/wasienv/threads/demothreads.lpr Normal file
View File

@ -0,0 +1,73 @@
program demowasithreads;
{$mode objfpc}
uses
browserconsole, browserapp, JS, Classes, SysUtils, Web, WebAssembly, types,
wasienv, Rtl.WebThreads, wasihostapp, wasithreadedapp ;
Type
{ TMyApplication }
TMyApplication = class(TBrowserWASIThreadedHostApplication)
Private
BtnStart : TJSHTMLButtonElement;
procedure DoBeforeWasmInstantiate(Sender: TObject);
function DoStartClick(aEvent: TJSMouseEvent): boolean;
procedure DoWasmLoaded(Sender: TObject);
procedure DoWrite(Sender: TObject; aOutput: String);
Public
procedure doRun; override;
end;
procedure TMyApplication.DoWrite(Sender: TObject; aOutput: String);
begin
Writeln('Wasm: '+aOutput);
end;
function TMyApplication.DoStartClick(aEvent: TJSMouseEvent): boolean;
begin
Result:=false;
Writeln('Host: Starting program');
Host.Exported.start;
end;
procedure TMyApplication.DoBeforeWasmInstantiate(Sender: TObject);
begin
Writeln('Host: Webassembly downloaded, instantiating VM');
end;
procedure TMyApplication.DoWasmLoaded(Sender: TObject);
begin
Writeln('Host: wasm loaded, ready to run');
BtnStart.Disabled:=False;
end;
procedure TMyApplication.doRun;
begin
// Your code here
Terminate;
btnStart:=TJSHTMLButtonElement(GetHTMLElement('btnStart'));
btnStart.onclick:=@DoStartClick;
BtnStart.Disabled:=True;
Host.MemoryDescriptor.initial:=256;
Host.MemoryDescriptor.maximum:=512;
Host.OnConsoleWrite:=@DoWrite;
Host.AfterInstantation:=@DoWasmLoaded;
Host.BeforeInstantation:=@DoBeforeWasmInstantiate;
Writeln('Host: Loading wasm...');
StartWebAssembly('threadapp.wasm',False);
end;
var
Application : TMyApplication;
begin
MaxConsoleLines:=250;
Application:=TMyApplication.Create(nil);
Application.Initialize;
Application.Run;
end.

53
demo/wasienv/threads/index.html Normal file
View File

@ -0,0 +1,53 @@
<!doctype html>
<html lang="en">
<head>
<meta http-equiv="Content-type" content="text/html; charset=utf-8">
<meta name="viewport" content="width=device-width, initial-scale=1">
<title>FPC-Webassembly and Pas2JS Demo</title>
<link href="bulma.min.css" rel="stylesheet">
<!-- <link rel="stylesheet" href="https://cdn.jsdelivr.net/npm/bulma@0.9.3/css/bulma.min.css"> -->
<script src="demothreads.js"></script>
<style>
.source {
/* width: 730px; */
margin: -45px auto;
font-size: 0.9em;
}
.source-inner {
display: flex;
justify-content: space-between;
align-items: center;
/* width: 482px; */
}
</style>
</head>
<body>
<div class="section pb-4">
<h1 class="title is-4">FPC compiled Browser Host/Webassembly programs console output:</h1>
<div class="box" id="pasjsconsole"></div>
</div>
<div class="section pb-4">
<button id="btnStart" class="button is-primary" disabled>Start program</button>
</div>
<!-- <hr> -->
<div class="section">
<div class="source">
<div class="source-inner">
<div>
<p>Created using &nbsp; <a target="_blank" href="https://wiki.freepascal.org/pas2js">pas2js.</a> </p>
<p>Pas2JS Sources: &nbsp; <a target="new" href="demothreads.lpr">Pas2JS Program</a></p>
<p>Webassembly Sources: &nbsp; <a target="new" href="threadedapp.pp">FPC Program</a></p>
</div>
</div>
</div>
</div>
<script>
rtl.showUncaughtExceptions=true;
rtl.run();
</script>
</body>
</html>

68
demo/wasienv/threads/threadapp.lpi Normal file
View File

@ -0,0 +1,68 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="12"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
<MainUnitHasScaledStatement Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<Title Value="WASM Thread demo application"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<BuildModes>
<Item Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
</RunParams>
<Units>
<Unit>
<Filename Value="threadapp.lpr"/>
<IsPartOfProject Value="True"/>
</Unit>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="threadapp"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<CodeGeneration>
<TargetCPU Value="wasm32"/>
<TargetOS Value="wasi"/>
</CodeGeneration>
<Linking>
<Debugging>
<UseLineInfoUnit Value="False"/>
</Debugging>
</Linking>
<Other>
<CustomOptions Value="-CTwasmthreads"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions>
<Item>
<Name Value="EAbort"/>
</Item>
<Item>
<Name Value="ECodetoolError"/>
</Item>
<Item>
<Name Value="EFOpenError"/>
</Item>
</Exceptions>
</Debugging>
</CONFIG>

50
demo/wasienv/threads/threadapp.lpr Normal file
View File

@ -0,0 +1,50 @@
program threadapp;
{$mode objfpc}
{$h+}
{$i-}
uses SysUtils, Classes;
Function Fibonacci(N : Integer) : Int64;
Var
Next,Last : Int64;
I : Integer;
begin
if N=0 then
exit(0);
Result:=1;
Last:=0;
for I:=1 to N-1 do
begin
Next:=Result+last;
Last:=Result;
Result:=Next;
end;
end;
Type
{ TCalcThread }
TCalcThread = Class(TThread)
Procedure Execute; override;
end;
{ TCalcThread }
procedure TCalcThread.Execute;
begin
FreeOnTerminate:=True;
DebugWriteln('Fibonacci(10) = '+IntToStr(Fibonacci(10)));
end;
begin
DebugWriteln('Starting thread');
With TCalcThread.Create(False) do
begin
DebugWriteln('Thread created');
WaitFor;
DebugWriteln('thread ended');
end;
end.

927
demo/wasienv/threads/wasmthreads.pp Normal file
View File

@ -0,0 +1,927 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2022 by Michael Van Canneyt,
member of the Free Pascal development team.
wasm threading support implementation
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.
**********************************************************************}
{$mode objfpc}
{$modeswitch advancedrecords}
{$DEFINE DEBUG_MT}
unit wasmthreads;
interface
Procedure SetWasmThreadManager;
implementation
Uses
WebAssembly, wasiapi;
{*****************************************************************************
System unit import
*****************************************************************************}
procedure fpc_threaderror; [external name 'FPC_THREADERROR'];
Type
TTimeLockResult = (tlrOK,tlrTimeout,tlrError);
TFPWasmMutex = record
_lock : Longint;
_owner : Pointer;
function TryLock : Boolean;
function Lock : Boolean;
function TimedLock(aTimeOut : Longint) : TTimeLockResult;
function Unlock : Boolean;
end;
TFPWasmEvent = record
_mutex : TFPWasmMutex;
_isset : Boolean;
end;
PFPWasmThread = ^TFPWasmThread;
TFPWasmThread = record
ThreadID : Integer;
Next : PFPWasmThread;
Previous : PFPWasmThread;
end;
Var
MainThread : TFPWasmThread;
threadvarblocksize : dword = 0;
TLSInitialized : Integer = 0;
{$IFDEF DEBUG_MT}
Type
TSmallString = string[100];
Procedure SetTLSMemory(aValue : Pointer);
begin
fpc_wasm32_init_tls(aValue);
end;
Function GetTLSMemory : Pointer;
begin
Result:=fpc_wasm32_tls_base;
end;
Procedure RawWrite(var S : TSmallString);
begin
// ToDo
end;
{$ENDIF DEBUG_MT}
procedure WasmInitThreadvar(var offset : dword;size : dword);
begin
threadvarblocksize:=align(threadvarblocksize, fpc_wasm32_tls_align);
offset:=threadvarblocksize;
inc(threadvarblocksize,size);
end;
procedure WasmAllocateThreadVars;
var
tlsMemBlock : pointer;
tlsBlockSize : Integer;
begin
tlsBlockSize:=fpc_wasm32_tls_size;
if threadvarblocksize<>tlsBlocksize then
Writeln('Warning : block sizes differ: ',tlsBlocksize,'<>',threadvarblocksize,'(calculated) !');
// DataIndex:=Pointer(Fpmmap(nil,threadvarblocksize,3,MAP_PRIVATE+MAP_ANONYMOUS,-1,0));
FillChar(DataIndex^,threadvarblocksize,0);
// pthread_setspecific(tlskey,dataindex);
end;
procedure WasmThreadCleanup(p: pointer); cdecl;
{$ifdef DEBUG_MT}
var
s: TSmallString; // not an ansistring
{$endif DEBUG_MT}
begin
{$ifdef DEBUG_MT}
s := 'finishing externally started thread'#10;
RawWrite(s);
{$endif DEBUG_MT}
{ Restore tlskey value as it may already have been set to null,
in which case
a) DoneThread can't release the memory
b) accesses to threadvars from DoneThread or anything it
calls would allocate new threadvar memory
}
{ clean up }
DoneThread;
pthread_setspecific(CleanupKey,nil);
end;
procedure HookThread;
{ Set up externally created thread }
begin
WasmAllocateThreadVars;
InitThread(1000000000);
pthread_setspecific(CleanupKey,getTlsMemory);
end;
function WasmRelocateThreadvar(offset : dword) : pointer;
var
P : Pointer;
begin
P:=GetTLSMemory;
if (P=Nil) then
begin
HookThread;
P:=GetTLSMemory;
end;
WasmRelocateThreadvar:=P+Offset;
end;
procedure WasmReleaseThreadVars;
begin
Fpmunmap(pointer(pthread_getspecific(tlskey)),threadvarblocksize);
end;
function WasmThreadMain(param : pointer) : pointer;
var
{$ifdef DEBUG_MT}
s: TSmallString; // not an ansistring
{$endif DEBUG_MT}
begin
{$ifdef DEBUG_MT}
s := 'New thread started, initing threadvars'#10;
RawWrite(s);
{$endif DEBUG_MT}
{ Must be first, many system unit things depend on threadvars}
WasmAllocateThreadVars;
{ Copy parameter to local data }
{$ifdef DEBUG_MT}
s := 'New thread started, initialising ...'#10;
RawWrite(s);
{$endif DEBUG_MT}
ti:=pthreadinfo(param)^;
{ Initialize thread }
InitThread(ti.stklen);
dispose(pthreadinfo(param));
{ Start thread function }
{$ifdef DEBUG_MT}
writeln('Jumping to thread function');
{$endif DEBUG_MT}
WasmThreadMain:=pointer(ti.f(ti.p));
DoneThread;
pthread_exit(WasmThreadMain);
end;
Procedure InitWasmTLS;
begin
if (InterLockedExchange(longint(TLSInitialized),1) = 0) then
begin
{ We're still running in single thread mode, setup the TLS }
pthread_key_create(@TLSKey,nil);
InitThreadVars(@WasmRelocateThreadvar);
{ used to clean up threads that we did not create ourselves:
a) the default value for a key (and hence also this one) in
new threads is NULL, and if it's still like that when the
thread terminates, nothing will happen
b) if it's non-NULL, the destructor routine will be called
when the thread terminates
-> we will set it to 1 if the threadvar relocation routine is
called from a thread we did not create, so that we can
clean up everything at the end }
pthread_key_create(@CleanupKey,@WasmthreadCleanup);
end
end;
function WasmBeginThread(sa : Pointer;stacksize : PtrUInt;
ThreadFunction : tthreadfunc;p : pointer;
creationFlags : dword; var ThreadId : TThreadId) : TThreadID;
var
ti : pthreadinfo;
thread_attr : pthread_attr_t;
{$ifdef DEBUG_MT}
S : TSmallString;
{$endif DEBUG_MT}
begin
{$ifdef DEBUG_MT}
S:='Creating new thread';
RawWrite(S);
{$endif DEBUG_MT}
{ Initialize multithreading if not done }
if not TLSInitialized then
InitWasmTLS;
if not IsMultiThread then
begin
{ We're still running in single thread mode, lazy initialize thread support }
LazyInitThreading;
IsMultiThread:=true;
end;
{ 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;
ti^.stklen:=stacksize;
{ call pthread_create }
{$ifdef DEBUG_MT}
S:='Starting new thread';
RawWrite(S);
{$endif DEBUG_MT}
pthread_attr_init(@thread_attr);
{$if not defined(HAIKU)and not defined(BEOS) and not defined(ANDROID)}
{$if defined (solaris) or defined (netbsd) }
pthread_attr_setinheritsched(@thread_attr, PTHREAD_INHERIT_SCHED);
{$else not solaris}
pthread_attr_setinheritsched(@thread_attr, PTHREAD_EXPLICIT_SCHED);
{$endif not solaris}
{$ifend}
// will fail under linux -- apparently unimplemented
pthread_attr_setscope(@thread_attr, PTHREAD_SCOPE_PROCESS);
// don't create detached, we need to be able to join (waitfor) on
// the newly created thread!
//pthread_attr_setdetachstate(@thread_attr, PTHREAD_CREATE_DETACHED);
// set the stack size
if (pthread_attr_setstacksize(@thread_attr, stacksize)<>0) or
// and create the thread
(pthread_create(ppthread_t(@threadid), @thread_attr, @ThreadMain,ti) <> 0) then
begin
dispose(ti);
threadid := TThreadID(0);
end;
CBeginThread:=threadid;
pthread_attr_destroy(@thread_attr);
{$ifdef DEBUG_MT}
Str(ptrint(CBeginThread),S);
S:= 'BeginThread returning '+S;
RawWrite(S);
{$endif DEBUG_MT}
end;
procedure WasmEndThread(ExitCode : DWord);
begin
DoneThread;
pthread_detach(pthread_t(pthread_self()));
pthread_exit(pointer(ptrint(ExitCode)));
end;
function WasmSuspendThread (threadHandle : TThreadID) : dword;
// Not supported
begin
result:=dword(-1);
end;
function WasmResumeThread (threadHandle : TThreadID) : dword;
// Not supported
begin
result:=dword(-1);
end;
procedure WasmThreadSwitch; {give time to other threads}
begin
// Not supported
end;
function WasmKillThread (threadHandle : TThreadID) : dword;
begin
pthread_detach(pthread_t(threadHandle));
WasmKillThread := pthread_cancel(pthread_t(threadHandle));
end;
function WasmCloseThread (threadHandle : TThreadID) : dword;
begin
result:=0;
end;
function WasmWaitForThreadTerminate (threadHandle : TThreadID; TimeoutMs : longint) : dword; {0=no timeout}
var
LResultP: Pointer;
begin
pthread_join(pthread_t(threadHandle), @LResultP);
WasmWaitForThreadTerminate := dword(LResultP);
end;
function WasmThreadSetPriority (threadHandle : TThreadID; Prio: longint): boolean; {-15..+15, 0=normal}
begin
result:=false;
end;
function WasmThreadGetPriority (threadHandle : TThreadID): Integer;
begin
result:=0;
end;
function CGetCurrentThreadId : TThreadID;
begin
CGetCurrentThreadId := TThreadID (pthread_self());
end;
procedure CSetThreadDebugNameA(threadHandle: TThreadID; const ThreadName: AnsiString);
{$if defined(Linux) or defined(Android)}
var
CuttedName: AnsiString;
{$endif}
begin
{$if defined(Linux) or defined(Android)}
if ThreadName = '' then
Exit;
{$ifdef dynpthreads}
if Assigned(pthread_setname_np) then
{$endif dynpthreads}
begin
// length restricted to 16 characters including terminating null byte
CuttedName:=Copy(ThreadName, 1, 15);
if threadHandle=TThreadID(-1) then
begin
pthread_setname_np(pthread_self(), @CuttedName[1]);
end
else
begin
pthread_setname_np(pthread_t(threadHandle), @CuttedName[1]);
end;
end;
{$elseif defined(Darwin) or defined(iphonesim)}
{$ifdef dynpthreads}
if Assigned(pthread_setname_np) then
{$endif dynpthreads}
begin
// only allowed to set from within the thread
if threadHandle=TThreadID(-1) then
pthread_setname_np(@ThreadName[1]);
end;
{$else}
{$Warning SetThreadDebugName needs to be implemented}
{$endif}
end;
procedure CSetThreadDebugNameU(threadHandle: TThreadID; const ThreadName: UnicodeString);
begin
{$if defined(Linux) or defined(Android)}
{$ifdef dynpthreads}
if Assigned(pthread_setname_np) then
{$endif dynpthreads}
begin
CSetThreadDebugNameA(threadHandle, AnsiString(ThreadName));
end;
{$elseif defined(Darwin) or defined(iphonesim)}
{$ifdef dynpthreads}
if Assigned(pthread_setname_np) then
{$endif dynpthreads}
begin
CSetThreadDebugNameA(threadHandle, AnsiString(ThreadName));
end;
{$else}
{$Warning SetThreadDebugName needs to be implemented}
{$endif}
end;
{*****************************************************************************
Delphi/Win32 compatibility
*****************************************************************************}
procedure CInitCriticalSection(var CS);
var
MAttr : pthread_mutexattr_t;
res: longint;
begin
res:=pthread_mutexattr_init(@MAttr);
if res=0 then
begin
res:=pthread_mutexattr_settype(@MAttr,longint(_PTHREAD_MUTEX_RECURSIVE));
if res=0 then
res := pthread_mutex_init(@CS,@MAttr)
else
{ No recursive mutex support :/ }
fpc_threaderror
end
else
res:= pthread_mutex_init(@CS,NIL);
pthread_mutexattr_destroy(@MAttr);
if res <> 0 then
fpc_threaderror;
end;
procedure CEnterCriticalSection(var CS);
begin
if pthread_mutex_lock(@CS) <> 0 then
fpc_threaderror
end;
function CTryEnterCriticalSection(var CS):longint;
begin
if pthread_mutex_Trylock(@CS)=0 then
result:=1 // succes
else
result:=0; // failure
end;
procedure CLeaveCriticalSection(var CS);
begin
if pthread_mutex_unlock(@CS) <> 0 then
fpc_threaderror
end;
procedure CDoneCriticalSection(var CS);
begin
{ unlock as long as unlocking works to unlock it if it is recursive
some Delphi code might call this function with a locked mutex }
while pthread_mutex_unlock(@CS)=0 do
;
if pthread_mutex_destroy(@CS) <> 0 then
fpc_threaderror;
end;
{*****************************************************************************
Semaphore routines
*****************************************************************************}
type
TPthreadCondition = pthread_cond_t;
TPthreadMutex = pthread_mutex_t;
Tbasiceventstate=record
FCondVar: TPthreadCondition;
{$if defined(Linux) and not defined(Android)}
FAttr: pthread_condattr_t;
FClockID: longint;
{$ifend}
FEventSection: TPthreadMutex;
FWaiters: longint;
FIsSet,
FManualReset,
FDestroying : Boolean;
end;
plocaleventstate = ^tbasiceventstate;
// peventstate=pointer;
Const
wrSignaled = 0;
wrTimeout = 1;
wrAbandoned= 2;
wrError = 3;
function IntBasicEventCreate(EventAttributes : Pointer; AManualReset,InitialState : Boolean;const Name : ansistring):pEventState;
var
MAttr : pthread_mutexattr_t;
res : cint;
{$if defined(Linux) and not defined(Android)}
timespec: ttimespec;
{$ifend}
begin
new(plocaleventstate(result));
plocaleventstate(result)^.FManualReset:=AManualReset;
plocaleventstate(result)^.FWaiters:=0;
plocaleventstate(result)^.FDestroying:=False;
plocaleventstate(result)^.FIsSet:=InitialState;
{$if defined(Linux) and not defined(Android)}
res := pthread_condattr_init(@plocaleventstate(result)^.FAttr);
if (res <> 0) then
begin
FreeMem(result);
fpc_threaderror;
end;
if clock_gettime(CLOCK_MONOTONIC_RAW, @timespec) = 0 then
begin
res := pthread_condattr_setclock(@plocaleventstate(result)^.FAttr, CLOCK_MONOTONIC_RAW);
end
else
begin
res := -1; // No support for CLOCK_MONOTONIC_RAW
end;
if (res = 0) then
begin
plocaleventstate(result)^.FClockID := CLOCK_MONOTONIC_RAW;
end
else
begin
res := pthread_condattr_setclock(@plocaleventstate(result)^.FAttr, CLOCK_MONOTONIC);
if (res = 0) then
begin
plocaleventstate(result)^.FClockID := CLOCK_MONOTONIC;
end
else
begin
pthread_condattr_destroy(@plocaleventstate(result)^.FAttr);
FreeMem(result);
fpc_threaderror;
end;
end;
res := pthread_cond_init(@plocaleventstate(result)^.FCondVar, @plocaleventstate(result)^.FAttr);
if (res <> 0) then
begin
pthread_condattr_destroy(@plocaleventstate(result)^.FAttr);
FreeMem(result);
fpc_threaderror;
end;
{$else}
res := pthread_cond_init(@plocaleventstate(result)^.FCondVar, nil);
if (res <> 0) then
begin
FreeMem(result);
fpc_threaderror;
end;
{$ifend}
res:=pthread_mutexattr_init(@MAttr);
if res=0 then
begin
res:=pthread_mutexattr_settype(@MAttr,longint(_PTHREAD_MUTEX_RECURSIVE));
if Res=0 then
Res:=pthread_mutex_init(@plocaleventstate(result)^.feventsection,@MAttr)
else
res:=pthread_mutex_init(@plocaleventstate(result)^.feventsection,nil);
end
else
res:=pthread_mutex_init(@plocaleventstate(result)^.feventsection,nil);
pthread_mutexattr_destroy(@MAttr);
if res <> 0 then
begin
pthread_cond_destroy(@plocaleventstate(result)^.FCondVar);
{$if defined(Linux) and not defined(Android)}
pthread_condattr_destroy(@plocaleventstate(result)^.FAttr);
{$ifend}
FreeMem(result);
fpc_threaderror;
end;
end;
procedure Intbasiceventdestroy(state:peventstate);
begin
{ safely mark that we are destroying this event }
pthread_mutex_lock(@plocaleventstate(state)^.feventsection);
plocaleventstate(state)^.FDestroying:=true;
{ send a signal to all threads that are waiting }
pthread_cond_broadcast(@plocaleventstate(state)^.FCondVar);
pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
{ now wait until they've finished their business }
while (plocaleventstate(state)^.FWaiters <> 0) do
cThreadSwitch;
{ and clean up }
pthread_cond_destroy(@plocaleventstate(state)^.Fcondvar);
{$if defined(Linux) and not defined(Android)}
pthread_condattr_destroy(@plocaleventstate(state)^.FAttr);
{$ifend}
pthread_mutex_destroy(@plocaleventstate(state)^.FEventSection);
dispose(plocaleventstate(state));
end;
procedure IntbasiceventResetEvent(state:peventstate);
begin
pthread_mutex_lock(@plocaleventstate(state)^.feventsection);
plocaleventstate(state)^.fisset:=false;
pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
end;
procedure IntbasiceventSetEvent(state:peventstate);
begin
pthread_mutex_lock(@plocaleventstate(state)^.feventsection);
plocaleventstate(state)^.Fisset:=true;
if not(plocaleventstate(state)^.FManualReset) then
pthread_cond_signal(@plocaleventstate(state)^.Fcondvar)
else
pthread_cond_broadcast(@plocaleventstate(state)^.Fcondvar);
pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
end;
function IntbasiceventWaitFor(Timeout : Cardinal;state:peventstate) : longint;
var
timespec: ttimespec;
errres: cint;
isset: boolean;
tnow : timeval;
begin
{ safely check whether we are being destroyed, if so immediately return. }
{ otherwise (under the same mutex) increase the number of waiters }
pthread_mutex_lock(@plocaleventstate(state)^.feventsection);
if (plocaleventstate(state)^.FDestroying) then
begin
pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
result := wrAbandoned;
exit;
end;
{ not a regular inc() because it may happen simulatneously with the }
{ interlockeddecrement() at the end }
interlockedincrement(plocaleventstate(state)^.FWaiters);
//Wait without timeout using pthread_cond_wait
if Timeout = $FFFFFFFF then
begin
while (not plocaleventstate(state)^.FIsSet) and (not plocaleventstate(state)^.FDestroying) do
pthread_cond_wait(@plocaleventstate(state)^.Fcondvar, @plocaleventstate(state)^.feventsection);
end
else
begin
//Wait with timeout using pthread_cond_timedwait
{$if defined(Linux) and not defined(Android)}
if clock_gettime(plocaleventstate(state)^.FClockID, @timespec) <> 0 then
begin
Result := Ord(wrError);
Exit;
end;
timespec.tv_sec := timespec.tv_sec + (clong(timeout) div 1000);
timespec.tv_nsec := ((clong(timeout) mod 1000) * 1000000) + (timespec.tv_nsec);
{$else}
// TODO: FIX-ME: Also use monotonic clock for other *nix targets
fpgettimeofday(@tnow, nil);
timespec.tv_sec := tnow.tv_sec + (clong(timeout) div 1000);
timespec.tv_nsec := ((clong(timeout) mod 1000) * 1000000) + (tnow.tv_usec * 1000);
{$ifend}
if timespec.tv_nsec >= 1000000000 then
begin
inc(timespec.tv_sec);
dec(timespec.tv_nsec, 1000000000);
end;
errres := 0;
while (not plocaleventstate(state)^.FDestroying) and
(not plocaleventstate(state)^.FIsSet) and
(errres<>ESysETIMEDOUT) do
errres := pthread_cond_timedwait(@plocaleventstate(state)^.Fcondvar,
@plocaleventstate(state)^.feventsection,
@timespec);
end;
isset := plocaleventstate(state)^.FIsSet;
{ if ManualReset=false, reset the event immediately. }
if (plocaleventstate(state)^.FManualReset=false) then
plocaleventstate(state)^.FIsSet := false;
//check the results...
if plocaleventstate(state)^.FDestroying then
Result := wrAbandoned
else
if IsSet then
Result := wrSignaled
else
begin
if errres=ESysETIMEDOUT then
Result := wrTimeout
else
Result := wrError;
end;
pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
{ don't put this above the previous pthread_mutex_unlock, because }
{ otherwise we can get errors in case an object is destroyed between }
{ end of the wait/sleep loop and the signalling above. }
{ The pthread_mutex_unlock above takes care of the memory barrier }
interlockeddecrement(plocaleventstate(state)^.FWaiters);
end;
function intRTLEventCreate: PRTLEvent;
var p:pintrtlevent;
begin
new(p);
if not assigned(p) then
fpc_threaderror;
if pthread_cond_init(@p^.condvar, nil)<>0 then
begin
dispose(p);
fpc_threaderror;
end;
if pthread_mutex_init(@p^.mutex, nil)<>0 then
begin
pthread_cond_destroy(@p^.condvar);
dispose(p);
fpc_threaderror;
end;
p^.isset:=false;
result:=PRTLEVENT(p);
end;
procedure intRTLEventDestroy(AEvent: PRTLEvent);
var p:pintrtlevent;
begin
p:=pintrtlevent(aevent);
pthread_cond_destroy(@p^.condvar);
pthread_mutex_destroy(@p^.mutex);
dispose(p);
end;
procedure intRTLEventSetEvent(AEvent: PRTLEvent);
var p:pintrtlevent;
begin
p:=pintrtlevent(aevent);
pthread_mutex_lock(@p^.mutex);
p^.isset:=true;
pthread_cond_signal(@p^.condvar);
pthread_mutex_unlock(@p^.mutex);
end;
procedure intRTLEventResetEvent(AEvent: PRTLEvent);
var p:pintrtlevent;
begin
p:=pintrtlevent(aevent);
pthread_mutex_lock(@p^.mutex);
p^.isset:=false;
pthread_mutex_unlock(@p^.mutex);
end;
procedure intRTLEventWaitFor(AEvent: PRTLEvent);
var p:pintrtlevent;
begin
p:=pintrtlevent(aevent);
pthread_mutex_lock(@p^.mutex);
while not p^.isset do pthread_cond_wait(@p^.condvar, @p^.mutex);
p^.isset:=false;
pthread_mutex_unlock(@p^.mutex);
end;
procedure intRTLEventWaitForTimeout(AEvent: PRTLEvent;timeout : longint);
var
p : pintrtlevent;
errres : cint;
timespec : ttimespec;
tnow : timeval;
begin
p:=pintrtlevent(aevent);
fpgettimeofday(@tnow,nil);
timespec.tv_sec:=tnow.tv_sec+(timeout div 1000);
timespec.tv_nsec:=(timeout mod 1000)*1000000 + tnow.tv_usec*1000;
if timespec.tv_nsec >= 1000000000 then
begin
inc(timespec.tv_sec);
dec(timespec.tv_nsec, 1000000000);
end;
errres:=0;
pthread_mutex_lock(@p^.mutex);
while (not p^.isset) and
(errres <> ESysETIMEDOUT) do
begin
errres:=pthread_cond_timedwait(@p^.condvar, @p^.mutex, @timespec);
end;
p^.isset:=false;
pthread_mutex_unlock(@p^.mutex);
end;
type
threadmethod = procedure of object;
Function CInitThreads : Boolean;
begin
{$ifdef DEBUG_MT}
Writeln('Entering InitThreads.');
{$endif}
{$ifndef dynpthreads}
Result:=True;
{$else}
Result:=LoadPthreads;
{$endif}
ThreadID := TThreadID (pthread_self());
{$ifdef DEBUG_MT}
Writeln('InitThreads : ',Result);
{$endif DEBUG_MT}
// We assume that if you set the thread manager, the application is multithreading.
InitCTLS;
end;
Function CDoneThreads : Boolean;
begin
{$ifndef dynpthreads}
Result:=True;
{$else}
Result:=UnloadPthreads;
{$endif}
end;
Var
CThreadManager : TThreadManager;
Procedure SetCThreadManager;
begin
With CThreadManager do begin
InitManager :=@WasmInitThreads;
DoneManager :=@WasmDoneThreads;
BeginThread :=@WasmBeginThread;
EndThread :=@WasmEndThread;
SuspendThread :=@WasmSuspendThread;
ResumeThread :=@WasmResumeThread;
KillThread :=@WasmKillThread;
ThreadSwitch :=@WasmThreadSwitch;
CloseThread :=@WasmCloseThread;
WaitForThreadTerminate :=@WasmWaitForThreadTerminate;
ThreadSetPriority :=@WasmThreadSetPriority;
ThreadGetPriority :=@WasmThreadGetPriority;
GetCurrentThreadId :=@WasmGetCurrentThreadId;
SetThreadDebugNameA :=@WasmSetThreadDebugNameA;
SetThreadDebugNameU :=@WasmSetThreadDebugNameU;
InitCriticalSection :=@WasmInitCriticalSection;
DoneCriticalSection :=@WasmDoneCriticalSection;
EnterCriticalSection :=@WasmEnterCriticalSection;
TryEnterCriticalSection:=@WasmTryEnterCriticalSection;
LeaveCriticalSection :=@WasmLeaveCriticalSection;
InitThreadVar :=@WasmInitThreadVar;
RelocateThreadVar :=@WasmRelocateThreadVar;
AllocateThreadVars :=@WasmAllocateThreadVars;
ReleaseThreadVars :=@WasmReleaseThreadVars;
BasicEventCreate :=@intBasicEventCreate;
BasicEventDestroy :=@intBasicEventDestroy;
BasicEventResetEvent :=@intBasicEventResetEvent;
BasicEventSetEvent :=@intBasicEventSetEvent;
BasiceventWaitFor :=@intBasiceventWaitFor;
rtlEventCreate :=@intrtlEventCreate;
rtlEventDestroy :=@intrtlEventDestroy;
rtlEventSetEvent :=@intrtlEventSetEvent;
rtlEventResetEvent :=@intrtlEventResetEvent;
rtleventWaitForTimeout :=@intrtleventWaitForTimeout;
rtleventWaitFor :=@intrtleventWaitFor;
end;
SetThreadManager(CThreadManager);
end;
initialization
if ThreadingAlreadyUsed then
begin
writeln('Threading has been used before cthreads was initialized.');
writeln('Make wasmthreads one of the first units in your uses clause.');
runerror(211);
end;
SetWasmThreadManager;
finalization
end.

477
packages/rtl/rtl.webthreads.pas Normal file
View File

@ -0,0 +1,477 @@
unit Rtl.WebThreads;
{$mode ObjFPC}
{$modeswitch externalclass}
interface
uses
JS, SysUtils, wasienv, webassembly;
Const
// Each thread starts spawning at 1000*IndexOfWorker
ThreadIDInterval = 1000;
// When the thread ID reaches this limit, then it requests a new block
ThreadIDMargin = 2;
// lowercase !!
cmdConsole = 'console';
cmdException = 'exception';
cmdCleanup = 'cleanup';
cmdCancel = 'cancel';
cmdLoaded = 'loaded';
cmdKill = 'kill';
cmdNeedIdBlock = 'needidblock';
cmdThreadIdRange = 'threadidrange';
cmdSpawn = 'spawn';
cmdLoad = 'load';
cmdRun = 'run';
DefaultThreadWorker = 'pas2jsthreadworker.js';
DefaultThreadCount = 2;
DefaultMaxWorkerCount = 100;
// Default exported thread entry point. Must have signature TThreadEntryPointFunction
DefaultThreadEntryPoint = 'FPC_WASM_THREAD_ENTRY';
// Default exported thread instance point. Must have signature TThreadInitInstanceFunction
DefaultThreadInstanceInitPoint = 'FPC_WASM_THREAD_INIT';
// Imports to wasi env.
sThreadSpawn = 'thread_spawn';
sThreadDetach = 'thread_detach';
sThreadCancel = 'thread_cancel';
sThreadSelf = 'thread_self';
Type
// aRunProc and aArgs are pointers inside wasm.
TThreadEntryPointFunction = Function(ThreadId: Integer; aRunProc : Integer; aArgs: Integer) : Integer;
TThreadInitInstanceFunction = Function(IsWorkerThread : Longint; IsMainThread : Integer; CanBlock : Integer) : Integer;
EWasmThreads = class(Exception);
// Commands sent between thread workers and main program.
{ Basic TWorkerCommand. Command is the actual command }
{ we do not use Pascal classes for this, to avoid transferring unnecessary metadata present in the pascal class }
TWorkerCommand = Class external name 'Object' (TJSObject)
Command : String;
ThreadID : Integer; // Meaning depends on actual command.
TargetID : Integer; // Forward to thread ID
end;
TCommandNotifyEvent = Procedure (Sender : TObject; aCommand : TWorkerCommand) of object;
{ TWorkerCommandHelper }
TWorkerCommandHelper = class helper for TWorkerCommand
Class function NewWorker(const aCommand : string; aThreadID : Integer = -1) : TWorkerCommand; static;
end;
{ TWorkerExceptionCommand }
// When an unexpected error occurred.
TWorkerExceptionCommand = class external name 'Object' (TWorkerCommand)
public
ExceptionClass: String;
ExceptionMessage: String;
end;
{ TWorkerExceptionCommandHelper }
TWorkerExceptionCommandHelper = class helper for TWorkerExceptionCommand
Class function CommandName : string; static;
Class function CreateNew(const aExceptionClass,aExceptionMessage : string; aThreadID : Integer = -1) : TWorkerExceptionCommand; static;
end;
{ TWorkerConsoleCommand }
// Sent by worker to main: write message to console
// Thread ID : sending console ID
TWorkerConsoleCommand = class external name 'Object' (TWorkerCommand)
public
ConsoleMessage : String;
end;
{ TWorkerConsoleCommandHelper }
TWorkerConsoleCommandHelper = class helper for TWorkerConsoleCommand
Class function CommandName : string; static;
Class function Create(const aMessage : string; aThreadID : Integer = -1) : TWorkerConsoleCommand; static; reintroduce;
Class function Create(const aMessage : array of JSValue; aThreadID : Integer = -1) : TWorkerConsoleCommand; static; reintroduce;
end;
// Cleanup thread info: put this worker into unusued workers
TWorkerCleanupCommand = class external name 'Object' (TWorkerCommand)
end;
{ TWorkerCleanupCommandHelper }
TWorkerCleanupCommandHelper = class helper for TWorkerCleanupCommand
Class function CommandName : string; static;
Class function Create(aThreadID : Integer): TWorkerCleanupCommand; static; reintroduce;
end;
{ TWorkerKillCommand }
// Kill thread (thread ID in ThreadID)
TWorkerKillCommand = class external name 'Object' (TWorkerCommand)
end;
{ TWorkerCleanupCommandHelper }
TWorkerKillCommandHelper = class helper for TWorkerKillCommand
Class function CommandName : string; static;
Class function Create(aThreadID : Integer): TWorkerKillCommand; static;reintroduce;
end;
// Cancel thread (thread ID in ThreadID)
TWorkerCancelCommand = class external name 'Object' (TWorkerCommand)
end;
{ TWorkerCancelCommandHelper }
TWorkerCancelCommandHelper = class helper for TWorkerCancelCommand
Class function CommandName : string; static;
Class function Create(aThreadID : Integer): TWorkerCancelCommand; static; reintroduce;
end;
// sent to notify main thread that the wasm module is loaded.
TWorkerLoadedCommand = class external name 'Object' (TWorkerCommand)
end;
{ TWorkerLoadedCommandHelper }
TWorkerLoadedCommandHelper = class helper for TWorkerLoadedCommand
Class function CommandName : string; static;
Class function Create: TWorkerLoadedCommand; static; reintroduce;
end;
// Sent to notify main thread that a new range of IDs is needed.
TWorkerNeedIdBlockCommand = class external name 'Object' (TWorkerCommand)
Current : NativeInt;
end;
{ TWorkerNeedIdBlockCommandHelper }
TWorkerNeedIdBlockCommandHelper = class helper for TWorkerNeedIdBlockCommand
Class function CommandName : string; static;
Class function Create(aCurrent : NativeInt): TWorkerNeedIdBlockCommand; static; reintroduce;
end;
// Sent to notify main thread that a new thread must be started.
// Worker cannot start new thread. It allocates the ID (threadId)
// It sends RunFunction, Attributes and Arguments received by thread_spawn call.
TWorkerSpawnThreadCommand = class external name 'Object' (TWorkerCommand)
Attributes : Integer;
Arguments : Integer;
RunFunction : Integer;
ThreadInfo : integer;
end;
{ TWorkerSpawnThreadCommandHelper }
TWorkerSpawnThreadCommandHelper = class helper for TWorkerSpawnThreadCommand
Class function CommandName : string; static;
Class function Create(aThreadID : integer; aAttrs,aArgs,aRun,aThreadInfo : Integer): TWorkerSpawnThreadCommand; static;reintroduce;
end;
// Sent by main to worker: load wasm module
TWorkerLoadCommand = class external name 'Object' (TWorkerCommand)
public
Memory : TJSWebAssemblyMemory;
Module : TJSWebAssemblyModule;
ThreadRangeStart : NativeInt;
end;
{ TWorkerLoadCommandHelper }
TWorkerLoadCommandHelper = class helper for TWorkerLoadCommand
Class function CommandName : string; static;
Class function Create(aStartThreadIdRange : integer; aModule : TJSWebAssemblyModule; aMemory : TJSWebAssemblyMemory): TWorkerLoadCommand; static;reintroduce;
end;
// Sent by main to worker: run thread procedure
TWorkerRunCommand = class external name 'Object' (TWorkerCommand)
public
ThreadInfo : Integer;
RunThreadProc : Integer;
Attrs : Integer;
Args : Integer;
end;
{ TWorkerRunCommandHelper }
TWorkerRunCommandHelper = class helper for TWorkerRunCommand
Class function CommandName : string; static;
Class function Create(aThreadID, aRunProc, aAttrs, aArgs, aThreadInfoLocation : integer): TWorkerRunCommand; static; reintroduce;
end;
// Sent to worker with new range of thread IDs.
TWorkerThreadIDRangeCommand = class external name 'Object' (TWorkerCommand)
RangeStart : NativeInt;
end;
{ TWorkerThreadIDRangeCommandHelper }
TWorkerThreadIDRangeCommandHelper = class helper for TWorkerThreadIDRangeCommand
Class function CommandName : string; static;
class function Create(aRangeStart: NativeInt): TWorkerThreadIDRangeCommand; static; reintroduce;
end;
TThreadinfo = record
OriginThreadID : Integer; // Numerical thread ID
ThreadID : Integer; // Numerical thread ID
ThreadInfoLocation : Integer; // Location of thread block (pointer)
RunFunction : Integer; // Location of thread function (pointer)
Attributes : Integer; // Unused for the moment
Arguments : Integer; // Arguments (pointer)
end;
// This basis object has the thread support that is needed by the WASM module.
// It relies on descendents to implement the actual calls.
{ TWasmThreadSupport }
TWasmThreadSupport = Class (TImportExtension)
private
FOnSendCommand: TCommandNotifyEvent;
Protected
// Proposed WASI standard, modeled after POSIX pthreads.
Function thread_spawn(thread_id : Integer; attrs: Integer; thread_start_func : Integer; args : Integer) : Integer; virtual; abstract;
Function thread_detach(thread_id : Integer) : Integer; virtual; abstract;
Function thread_cancel(thread_id : Integer) : Integer; virtual; abstract;
Function thread_self() : Integer; virtual; abstract;
Public
Function ImportName : String; override;
procedure FillImportObject(aObject: TJSObject); override;
Procedure HandleCommand(aCommand : TWorkerCommand); virtual;
Procedure SendCommand(aCommand : TWorkerCommand); virtual;
// Set this to actually send commands. Normally set by TWorkerWASIHostApplication
Property OnSendCommand : TCommandNotifyEvent Read FOnSendCommand Write FOnSendCommand;
end;
implementation
{ TWorkerRunCommandHelper }
class function TWorkerRunCommandHelper.CommandName: string;
begin
Result:=cmdRun;
end;
class function TWorkerRunCommandHelper.Create(aThreadID, aRunProc, aAttrs,
aArgs, aThreadInfoLocation: integer): TWorkerRunCommand;
begin
Result:=TWorkerRunCommand(TWorkerCommand.NewWorker(CommandName));
Result.ThreadID:=aThreadID;
Result.ThreadInfo:=aThreadInfoLocation;
Result.RunThreadProc:=aRunProc;
Result.Attrs:=aAttrs;
Result.Args:=aArgs;
end;
{ TWorkerLoadCommandHelper }
class function TWorkerLoadCommandHelper.CommandName: string;
begin
Result:=cmdLoad;
end;
class function TWorkerLoadCommandHelper.Create(aStartThreadIdRange: integer;
aModule: TJSWebAssemblyModule; aMemory: TJSWebAssemblyMemory
): TWorkerLoadCommand;
begin
Result:=TWorkerLoadCommand(TWorkerCommand.NewWorker(CommandName));
Result.ThreadRangeStart:=aStartThreadIdRange;
Result.Memory:=aMemory;
Result.Module:=aModule;
end;
{ TWorkerSpawnThreadCommandHelper }
class function TWorkerSpawnThreadCommandHelper.CommandName: string;
begin
Result:=cmdSpawn
end;
class function TWorkerSpawnThreadCommandHelper.Create(aThreadID: integer;
aAttrs, aArgs, aRun, aThreadInfo: Integer): TWorkerSpawnThreadCommand;
begin
Result:=TWorkerSpawnThreadCommand(TWorkerCommand.NewWorker(CommandName,aThreadID));
Result.Arguments:=aArgs;
Result.Attributes:=aAttrs;
Result.RunFunction:=aRun;
Result.ThreadInfo:=aThreadInfo;
end;
{ TWorkerThreadIDRangeCommandHelper }
class function TWorkerThreadIDRangeCommandHelper.CommandName: string;
begin
Result:=cmdThreadIdRange;
end;
class function TWorkerThreadIDRangeCommandHelper.Create(aRangeStart: NativeInt
): TWorkerThreadIDRangeCommand;
begin
Result:=TWorkerThreadIDRangeCommand(TWorkerCommand.NewWorker(CommandName));
Result.RangeStart:=aRangeStart;
end;
{ TWorkerNeedIdBlockCommandHelper }
class function TWorkerNeedIdBlockCommandHelper.CommandName: string;
begin
Result:=cmdNeedIdBlock;
end;
class function TWorkerNeedIdBlockCommandHelper.Create(aCurrent: NativeInt
): TWorkerNeedIdBlockCommand;
begin
Result:=TWorkerNeedIdBlockCommand(TWorkerCommand.NewWorker(CommandName));
Result.Current:=aCurrent;
end;
{ TWorkerLoadedCommandHelper }
class function TWorkerLoadedCommandHelper.CommandName: string;
begin
Result:=cmdLoaded;
end;
class function TWorkerLoadedCommandHelper.Create: TWorkerLoadedCommand;
begin
Result:=TWorkerLoadedCommand(TWorkerCommand.NewWorker(CommandName));
end;
{ TWorkerCancelCommandHelper }
class function TWorkerCancelCommandHelper.CommandName: string;
begin
result:=cmdCancel;
end;
class function TWorkerCancelCommandHelper.Create(aThreadID: Integer
): TWorkerCancelCommand;
begin
Result:=TWorkerCancelCommand(TWorkerCommand.NewWorker(CommandName,aThreadID));
end;
{ TWorkerKillCommandHelper }
class function TWorkerKillCommandHelper.CommandName: string;
begin
Result:=cmdKill
end;
class function TWorkerKillCommandHelper.Create(aThreadID : Integer): TWorkerKillCommand;
begin
Result:=TWorkerKillCommand(TWorkerCommand.NewWorker(CommandName,aThreadID));
end;
{ TWorkerCleanupCommandHelper }
class function TWorkerCleanupCommandHelper.CommandName: string;
begin
Result:=cmdCleanup
end;
class function TWorkerCleanupCommandHelper.Create(aThreadID: Integer): TWorkerCleanupCommand;
begin
Result:=TWorkerCleanupCommand(TWorkerCommand.NewWorker(CommandName,aThreadID));
end;
{ TWorkerConsoleCommandHelper }
class function TWorkerConsoleCommandHelper.CommandName: string;
begin
Result:=cmdConsole;
end;
class function TWorkerConsoleCommandHelper.Create(
const aMessage: string; aThreadID : Integer = -1): TWorkerConsoleCommand;
begin
Result:=TWorkerConsoleCommand(TWorkerCommand.NewWorker(CommandName,aThreadID));
Result.ConsoleMessage:=aMessage;
end;
class function TWorkerConsoleCommandHelper.Create(
const aMessage: array of JSValue; aThreadID : Integer = -1): TWorkerConsoleCommand;
begin
Result:=Create(TJSArray(aMessage).join(' '),aThreadID);
end;
{ TWorkerExceptionCommandHelper }
class function TWorkerExceptionCommandHelper.CommandName: string;
begin
Result:=cmdException;
end;
class function TWorkerExceptionCommandHelper.CreateNew(const aExceptionClass,aExceptionMessage: string; aThreadID : Integer = -1 ): TWorkerExceptionCommand;
begin
Result:=TWorkerExceptionCommand(TWorkerCommand.NewWorker(CommandName,aThreadID));
Result.ExceptionClass:=aExceptionClass;
Result.ExceptionMessage:=aExceptionMessage;
end;
{ TWorkerCommandHelper }
class function TWorkerCommandHelper.NewWorker(const aCommand : string; aThreadID : Integer = -1): TWorkerCommand;
begin
Result:=TWorkerCommand.New;
Result.Command:=LowerCase(aCommand);
if aThreadID<>-1 then
Result.ThreadID:=aThreadID;
end;
{ TWasmThreadSupport }
function TWasmThreadSupport.ImportName: String;
begin
Result:='FPCThreading';
end;
procedure TWasmThreadSupport.FillImportObject(aObject: TJSObject);
begin
aObject[sThreadSpawn]:=@Thread_Spawn;
aObject[sThreadDetach]:=@Thread_Detach;
aObject[sThreadCancel]:=@Thread_Cancel;
aObject[sThreadSelf]:=@Thread_Self;
end;
procedure TWasmThreadSupport.HandleCommand(aCommand: TWorkerCommand);
Var
P : TWorkerExceptionCommand;
begin
P:=TWorkerExceptionCommand.New;
P.ExceptionClass:='ENotSupportedException';
P.ExceptionMessage:='Unsupported command : '+TJSJSON.Stringify(aCommand);
SendCommand(aCommand);
end;
procedure TWasmThreadSupport.SendCommand(aCommand: TWorkerCommand);
begin
if Assigned(FOnSendCommand) then
FOnSendCommand(Self,aCommand);
end;
end.

10
packages/rtl/webassembly.pas
View File

@ -6,7 +6,7 @@ unit webassembly;
interface
uses
js, Weborworker;
js;
Type
{ TJSWebAssemblyMemory }
@ -36,7 +36,7 @@ Type
FMemory : TJSWebAssemblyMemory; external name 'memory';
function GetFun(aName : String): TJSFunction; external name '[]';
public
Property Memory : TJSWebAssemblyMemory Read FMemory;
Property Memory : TJSWebAssemblyMemory Read FMemory Write fMemory;
Property functions [aName : String] : TJSFunction read GetFun; default;
end;
@ -80,9 +80,9 @@ Type
Class Function instantiate(Buffer : TJSWebAssemblyModule; ImportObject : TJSObject) : TJSPromise; overload;
Class Function instantiate(Buffer : TJSWebAssemblyModule) : TJSPromise; overload;
Class Function compile(Buffer : TJSArrayBuffer): TJSPromise;
Class Function compileStreaming(source : TJSResponse): TJSPromise;
Class Function instantiateStreaming(source : TJSResponse; ImportObject : TJSObject) : TJSPromise; overload;
Class Function instantiateStreaming(source : TJSResponse) : TJSPromise; overload;
Class Function compileStreaming(source : TJSObject): TJSPromise;
Class Function instantiateStreaming(source : TJSObject; ImportObject : TJSObject) : TJSPromise; overload;
Class Function instantiateStreaming(source : TJSObject) : TJSPromise; overload;
Class Function validate(Buffer : TJSArrayBuffer): Boolean;
end;

77
packages/wasi/pas2jsthreadworker.lpi Normal file
View File

@ -0,0 +1,77 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="12"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
<MainUnitHasScaledStatement Value="False"/>
<Runnable Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<Title Value="pas2jsthreadworker"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<BuildModes>
<Item Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
</RunParams>
<Units>
<Unit>
<Filename Value="pas2jsthreadworker.pas"/>
<IsPartOfProject Value="True"/>
</Unit>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target FileExt=".js">
<Filename Value="pas2jsthreadworker"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="js"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<AllowLabel Value="False"/>
<CPPInline Value="False"/>
<UseAnsiStrings Value="False"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<TargetOS Value="nodejs"/>
</CodeGeneration>
<Linking>
<Debugging>
<GenerateDebugInfo Value="False"/>
<UseLineInfoUnit Value="False"/>
</Debugging>
</Linking>
<Other>
<CustomOptions Value="-Jeutf-8 -Jminclude -Jirtl.js"/>
<CompilerPath Value="$(pas2js)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions>
<Item>
<Name Value="EAbort"/>
</Item>
<Item>
<Name Value="ECodetoolError"/>
</Item>
<Item>
<Name Value="EFOpenError"/>
</Item>
</Exceptions>
</Debugging>
</CONFIG>

22
packages/wasi/pas2jsthreadworker.pas Normal file
View File

@ -0,0 +1,22 @@
program pas2jsthreadworker;
{$mode objfpc}
uses
Classes, WasiWorkerThreadHost;
type
{ TApplication }
TApplication = class(TWorkerWASIHostApplication)
end;
{ TApplication }
var
App: TApplication;
begin
App:=TApplication.Create(nil);
App.Run;
end.

302
packages/wasi/wasienv.pas
View File

@ -4,7 +4,8 @@ unit wasienv;
{$mode ObjFPC}
{$modeswitch externalclass}
{$INTERFACES CORBA}
{$WARN 5024 off}
{$WARN 4501 off}
interface
uses
@ -327,10 +328,12 @@ type
FOnStdOutputWrite: TWASIWriteEvent;
FImportExtensions : TFPList;
FWASIImportName : string;
FMemory : TJSWebAssemblyMemory;
function GetConsoleInputBuffer: TJSUint8Array;
function GetFileBuffer(FD: NativeInt): TJSUint8Array;
function GetImportObject: TJSObject;
function getiovs(view: TJSDataView; iovs, iovsLen: NativeInt): TJSArray;
function GetMemory: TJSWebassemblyMemory;
procedure SetInstance(AValue: TJSWebAssemblyInstance);
Protected
Class Var UTF8TextDecoder: TJSTextDecoder;
@ -392,6 +395,8 @@ type
function sock_recv() : NativeInt; virtual;
function sock_send() : NativeInt; virtual;
function sock_shutdown() : NativeInt; virtual;
Protected
Procedure SetMemory(aMemory : TJSWebAssemblyMemory);
Public
class constructor init;
Constructor Create;
@ -414,6 +419,7 @@ type
Property OnGetConsoleInputBuffer : TGetConsoleInputBufferEvent Read FOnGetConsoleInputBuffer Write FOnGetConsoleInputBuffer;
Property OnGetConsoleInputString : TGetConsoleInputStringEvent Read FOnGetConsoleInputString Write FOnGetConsoleInputString;
Property Instance : TJSWebAssemblyInstance Read Finstance Write SetInstance;
Property Memory : TJSWebassemblyMemory Read GetMemory;
Property Exitcode : Nativeint Read FExitCode;
// Default is set to the one expected by FPC runtime: wasi_snapshot_preview1
Property WASIImportName : String Read FWASIImportName Write FWASIImportName;
@ -434,11 +440,25 @@ type
Property Env : TPas2JSWASIEnvironment Read FEnv;
end;
TRunWebassemblyProc = reference to Procedure(aExports : TWASIExports);
TWebAssemblyStartDescriptor = record
// Module
Module : TJSWebAssemblyModule;
// memory to use
Memory : TJSWebAssemblyMemory;
// Table to use
Table : TJSWebAssemblyTable;
// Exports of module
Exported : TWASIExports;
// Imports of module
Imports : TJSOBject;
// Instance
Instance : TJSWebAssemblyInstance;
// Procedure to actually run a function.
CallRun : TRunWebassemblyProc;
// After run, if an exception occurred, this is filled with error class/message.
RunExceptionClass : String;
RunExceptionMessage : String;
end;
@ -448,6 +468,8 @@ type
TBeforeStartEvent = Procedure (Sender : TObject; aDescriptor : TWebAssemblyStartDescriptor; var aAllowRun : Boolean) of object;
TAfterStartEvent = Procedure (Sender : TObject; aDescriptor : TWebAssemblyStartDescriptor) of object;
TFailEvent = Procedure (Sender : TObject; aFail : JSValue) of object;
TConsoleReadEvent = Procedure(Sender : TObject; Var AInput : String) of object;
TConsoleWriteEvent = Procedure (Sender : TObject; aOutput : string) of object;
@ -455,10 +477,15 @@ type
TWASIHost = Class(TComponent)
Private
FAfterInstantation: TNotifyEvent;
FAfterStart: TAfterStartEvent;
FBeforeInstantation: TNotifyEvent;
FBeforeStart: TBeforeStartEvent;
FEnv: TPas2JSWASIEnvironment;
FExported: TWASIExports;
FOnInstantiateFail: TFailEvent;
FOnLoadFail: TFailEvent;
FPreparedStartDescriptor: TWebAssemblyStartDescriptor;
FMemoryDescriptor : TJSWebAssemblyMemoryDescriptor;
FOnConsoleRead: TConsoleReadEvent;
FOnConsoleWrite: TConsoleWriteEvent;
@ -466,21 +493,51 @@ type
FReadLineCount : Integer;
FRunEntryFunction: String;
FTableDescriptor : TJSWebAssemblyTableDescriptor;
function GetStartDescriptorReady: Boolean;
function GetUseSharedMemory: Boolean;
procedure SetPredefinedConsoleInput(AValue: TStrings);
procedure SetUseSharedMemory(AValue: Boolean);
protected
// Called after instantiation was OK.
Procedure DoAfterInstantiate; virtual;
// Called before instantiation starts.
Procedure DoBeforeInstantiate; virtual;
// Called when loading fails
Procedure DoLoadFail(aError : JSValue); virtual;
// Called when instantiating fails
Procedure DoInstantiateFail(aError : JSValue); virtual;
// Prepare start descriptor
Procedure PrepareWebAssemblyInstance(aDescr: TWebAssemblyStartDescriptor); virtual;
// Call the run function on an instantiated webassembly
function RunWebAssemblyInstance(aBeforeStart: TBeforeStartCallback; aAfterStart: TAfterStartCallback; aRun : TRunWebassemblyProc): Boolean; virtual; overload;
// Prepare and run web assembly instance.
function RunWebAssemblyInstance(aDescr: TWebAssemblyStartDescriptor; aBeforeStart: TBeforeStartCallback; aAfterStart: TAfterStartCallback): Boolean; overload;
// Standard Input/Output reads
procedure DoStdRead(Sender: TObject; var AInput: string); virtual;
procedure DoStdWrite(Sender: TObject; const aOutput: String); virtual;
// Load file from path ans instantiate a webassembly from it.
function CreateWebAssembly(aPath: string; aImportObject: TJSObject): TJSPromise; virtual;
// Create a WASI environment. Called during constructor, override to customize.
Function CreateWasiEnvironment : TPas2JSWASIEnvironment; virtual;
// Create Standard webassembly table description
function GetTable: TJSWebAssemblyTable; virtual;
// Create tandard webassembly memory.
function GetMemory: TJSWebAssemblyMemory; virtual;
public
Constructor Create(aOwner : TComponent); override;
Destructor Destroy; override;
// Will call OnConsoleWrite or write to console
procedure WriteOutput(const aOutput: String); virtual;
// Get prepared descriptor
Property PreparedStartDescriptor : TWebAssemblyStartDescriptor Read FPreparedStartDescriptor;
// Initialize a start descriptor.
function InitStartDescriptor(aMemory: TJSWebAssemblyMemory; aTable: TJSWebAssemblyTable; aImportObj: TJSObject): TWebAssemblyStartDescriptor;
// Load and start webassembly. If DoRun is true, then Webassembly entry point is called.
// If aBeforeStart is specified, then it is called prior to calling run, and can disable running.
// If aAfterStart is specified, then it is called after calling run. It is not called if running was disabled.
Procedure StartWebAssembly(aPath: string; DoRun : Boolean = True; aBeforeStart : TBeforeStartCallback = Nil; aAfterStart : TAfterStartCallback = Nil);
Procedure StartWebAssembly(aPath: string; DoRun: Boolean; aBeforeStart: TBeforeStartCallback; aAfterStart: TAfterStartCallback);
// Run the prepared descriptor
Procedure RunPreparedDescriptor;
// Initial memory descriptor
Property MemoryDescriptor : TJSWebAssemblyMemoryDescriptor Read FMemoryDescriptor Write FMemoryDescriptor;
// Import/export table descriptor
@ -489,8 +546,11 @@ type
Property WasiEnvironment : TPas2JSWASIEnvironment Read FEnv;
// Exported functions. Also available in start descriptor.
Property Exported : TWASIExports Read FExported;
// Is the descriptor prepared ?
Property StartDescriptorReady : Boolean Read GetStartDescriptorReady;
// Default console input
Property PredefinedConsoleInput : TStrings Read FPredefinedConsoleInput Write SetPredefinedConsoleInput;
// Name of function to run. If empty, the FPC default _start is used.
Property RunEntryFunction : String Read FRunEntryFunction Write FRunEntryFunction;
// Called after webassembly start was run. Not called if webassembly was not run.
@ -501,6 +561,17 @@ type
property OnConsoleRead : TConsoleReadEvent Read FOnConsoleRead Write FOnConsoleRead;
// Called when writing to console (stdout). If not set, console.log is used.
property OnConsoleWrite : TConsoleWriteEvent Read FOnConsoleWrite Write FOnConsoleWrite;
// Called when fetch of the wasm module fails.
Property OnLoadFail : TFailEvent Read FOnLoadFail Write FOnLoadFail;
// Called when instantiation of the wasm module fails.
Property OnInstantiateFail : TFailEvent Read FOnInstantiateFail Write FOnInstantiateFail;
// Use Shared memory for webassembly instances ?
Property UseSharedMemory : Boolean Read GetUseSharedMemory Write SetUseSharedMemory;
// Executed after instantiation
Property AfterInstantation : TNotifyEvent Read FAfterInstantation Write FAfterInstantation;
// Executed before instantiation
Property BeforeInstantation : TNotifyEvent Read FBeforeInstantation Write FBeforeInstantation;
end;
implementation
@ -534,30 +605,139 @@ begin
FPredefinedConsoleInput.Assign(AValue);
end;
function TWASIHost.GetUseSharedMemory: Boolean;
begin
Result:=FMemoryDescriptor.shared;
if isUndefined(Result) then
Result:=False;
end;
function TWASIHost.GetStartDescriptorReady: Boolean;
begin
With FPreparedStartDescriptor do
Result:=Assigned(Memory) and Assigned(Module);
end;
procedure TWASIHost.SetUseSharedMemory(AValue: Boolean);
begin
FMemoryDescriptor.shared:=aValue;
end;
procedure TWASIHost.DoAfterInstantiate;
begin
If Assigned(FAfterInstantation) then
FAfterInstantation(Self);
end;
procedure TWASIHost.DoBeforeInstantiate;
begin
If Assigned(FBeforeInstantation) then
FBeforeInstantation(Self);
end;
procedure TWASIHost.DoLoadFail(aError: JSValue);
begin
If Assigned(FOnLoadFail) then
FOnLoadFail(Self,aError);
end;
procedure TWASIHost.DoInstantiateFail(aError: JSValue);
begin
If Assigned(FOnInstantiateFail) then
FOnInstantiateFail(Self,aError);
end;
procedure TWASIHost.PrepareWebAssemblyInstance(
aDescr: TWebAssemblyStartDescriptor);
begin
FPreparedStartDescriptor:=aDescr;
FExported:=aDescr.Exported;
WasiEnvironment.Instance:=aDescr.Instance;
WasiEnvironment.SetMemory(aDescr.Memory);
// We do this here, so in the event, the FPreparedStartDescriptor Is ready.
DoAfterInstantiate;
end;
function TWASIHost.RunWebAssemblyInstance(aBeforeStart: TBeforeStartCallback; aAfterStart: TAfterStartCallback; aRun : TRunWebassemblyProc): Boolean;
begin
Result:=True;
// Writeln('Entering RunWebAssemblyInstance');
if Assigned(aBeforeStart) then
Result:=aBeforeStart(Self,FPreparedStartDescriptor);
if Assigned(FBeforeStart) then
FBeforeStart(Self,FPreparedStartDescriptor,Result);
if not Result then
exit;
try
if aRun=Nil then
aRun:=FPreparedStartDescriptor.CallRun;
aRun(FPreparedStartDescriptor.Exported);
if Assigned(aAfterStart) then
aAfterStart(Self,FPreparedStartDescriptor);
if Assigned(FAfterStart) then
FAfterStart(Self,FPreparedStartDescriptor)
except
On E : exception do
begin
FPreparedStartDescriptor.RunExceptionClass:=E.ClassName;
FPreparedStartDescriptor.RunExceptionMessage:=E.Message;
end;
On JE : TJSError do
begin
FPreparedStartDescriptor.RunExceptionClass:=jsTypeOf(JE);
FPreparedStartDescriptor.RunExceptionMessage:=JE.Message;
end;
On OE : TJSObject do
begin
FPreparedStartDescriptor.RunExceptionClass:=jsTypeOf(OE);
FPreparedStartDescriptor.RunExceptionMessage:=TJSJSON.Stringify(OE);
end;
end;
end;
procedure TWASIHost.DoStdWrite(Sender: TObject; const aOutput: String);
begin
if assigned(FOnConsoleWrite) then
FOnConsoleWrite(Self,aOutput)
else
Console.log('Webassembly output: ', aOutput);
WriteOutput(aOutput);
end;
function TWASIHost.CreateWebAssembly(aPath: string; aImportObject: TJSObject
): TJSPromise;
Function InstantiateOK(Res : JSValue) : JSValue;
begin
Result:=res;
end;
Function InstantiateFail(Res : JSValue) : JSValue;
begin
Result:=False;
DoInstantiateFail(res);
end;
Function ArrayOK(res2 : jsValue) : JSValue;
begin
Result:=TJSWebAssembly.instantiate(TJSArrayBuffer(res2),aImportObject);
DoBeforeInstantiate;
Result:=TJSWebAssembly.instantiate(TJSArrayBuffer(res2),aImportObject)._then(@InstantiateOK,@InstantiateFail);
end;
function fetchOK(res : jsValue) : JSValue;
begin
Result:=TJSResponse(Res).arrayBuffer._then(@ArrayOK,Nil)
Result:=TJSResponse(Res).arrayBuffer._then(@ArrayOK,Nil);
end;
function DoFail(res : jsValue) : JSValue;
begin
Result:=False;
DoLoadFail(res);
end;
begin
Result:=fetch(aPath)._then(@fetchOK);
Result:=fetch(aPath)._then(@fetchOK,@DoFail).Catch(@DoFail);
end;
function TWASIHost.CreateWasiEnvironment: TPas2JSWASIEnvironment;
@ -598,39 +778,48 @@ begin
inherited Destroy;
end;
procedure TWASIHost.StartWebAssembly(aPath: string; DoRun: Boolean;
aBeforeStart: TBeforeStartCallback; aAfterStart: TAfterStartCallback);
procedure TWASIHost.WriteOutput(const aOutput: String);
begin
if assigned(FOnConsoleWrite) then
FOnConsoleWrite(Self,aOutput)
else
Writeln(aOutput);
end;
function TWASIHost.RunWebAssemblyInstance(aDescr: TWebAssemblyStartDescriptor;
aBeforeStart: TBeforeStartCallback;
aAfterStart: TAfterStartCallback): Boolean;
begin
Result:=RunWebAssemblyInstance(aBeforeStart,aAfterStart,Nil);
end;
procedure TWASIHost.StartWebAssembly(aPath: string; DoRun: Boolean; aBeforeStart: TBeforeStartCallback; aAfterStart: TAfterStartCallback);
Var
ImportObj : TJSObject;
Res : TWebAssemblyStartDescriptor;
WASD : TWebAssemblyStartDescriptor;
function InitEnv(aValue: JSValue): JSValue;
Var
Module : TJSInstantiateResult absolute aValue;
InstResult : TJSInstantiateResult absolute aValue;
begin
Result:=True;
Res.Instance:=Module.Instance;
Res.Exported:=TWASIExports(TJSObject(Module.Instance.exports_));
// These 2 prevent running different instances simultaneously.
FExported:=Res.Exported;
WasiEnvironment.Instance:=Module.Instance;
if Assigned(aBeforeStart) then
DoRun:=aBeforeStart(Self,Res) and DoRun;
if Assigned(FBeforeStart) then
FBeforeStart(Self,Res,DoRun);
if DoRun then
WASD.Instance:=InstResult.Instance;
WASD.Module:=InstResult.Module;
WASD.Exported:=TWASIExports(TJSObject(WASD.Instance.exports_));
WASD.CallRun:=Procedure(aExports : TWASIExports)
begin
if FRunEntryFunction='' then
Res.Exported.Start
aExports.Start
else
TProcedure(Res.Exported[RunEntryFunction])();
if Assigned(aAfterStart) then
aAfterStart(Self,Res);
if Assigned(FAfterStart) then
FAfterStart(Self,Res)
TProcedure(aExports[RunEntryFunction])();
end;
PrepareWebAssemblyInstance(WASD);
if DoRun then
RunWebAssemblyInstance(aBeforeStart,aAfterStart,Nil);
end;
function DoFail(aValue: JSValue): JSValue;
@ -643,16 +832,32 @@ Var
begin
FReadLineCount:=0;
Res.Memory:=GetMemory;
Res.Table:=GetTable;
ImportObj:=new([
'js', new([
'mem', Res.Memory,
'tbl', Res.Table
])
// Clear current descriptor.
FPreparedStartDescriptor:=Default(TWebAssemblyStartDescriptor);
WASD:=InitStartDescriptor(GetMemory,GetTable,Nil);
CreateWebAssembly(aPath,WASD.Imports)._then(@initEnv,@DoFail).catch(@DoFail);
end;
procedure TWASIHost.RunPreparedDescriptor;
begin
RunWebAssemblyInstance(Nil,Nil,Nil)
end;
function TWASIHost.InitStartDescriptor(aMemory: TJSWebAssemblyMemory;
aTable: TJSWebAssemblyTable; aImportObj: TJSObject
): TWebAssemblyStartDescriptor;
begin
Result.Memory:=aMemory;
Result.Table:=aTable;
if Not assigned(aImportObj) then
aImportObj:=TJSObject.New;
aImportObj['env']:=new([
'memory', Result.Memory,
'tbl', Result.Table
]);
FEnv.AddImports(ImportObj);
CreateWebAssembly(aPath,ImportObj)._then(@initEnv,@DoFail)
FEnv.AddImports(aImportObj);
Result.Imports:=aImportObj;
end;
function TImportExtension.getModuleMemoryDataView : TJSDataView;
@ -711,7 +916,7 @@ end;
function TPas2JSWASIEnvironment.getModuleMemoryDataView: TJSDataView;
begin
Result:=TJSDataView.New(FModuleInstanceExports.memory.buffer);
Result:=TJSDataView.New(Memory.buffer);
end;
function TPas2JSWASIEnvironment.fd_prestat_get(fd, bufPtr: NativeInt
@ -813,6 +1018,8 @@ begin
if Finstance=AValue then Exit;
Finstance:=AValue;
FModuleInstanceExports:=Finstance.exports_;
if Not Assigned(FMemory) and Assigned(FModuleInstanceExports.Memory) then
FMemory:=FModuleInstanceExports.Memory;
end;
function TPas2JSWASIEnvironment.GetTime(aClockID: NativeInt): NativeInt;
@ -873,11 +1080,19 @@ begin
ptr:=iovs + i * 8;
buf:=view.getUint32(ptr, IsLittleEndian);
bufLen:=view.getUint32(ptr + 4, IsLittleEndian);
ArrayBuf:=TJSUint8Array.New(FModuleInstanceExports.memory.buffer, buf, bufLen);
ArrayBuf:=TJSUint8Array.New(Memory.buffer, buf, bufLen);
Result.Push(ArrayBuf);
end;
end;
function TPas2JSWASIEnvironment.GetMemory: TJSWebassemblyMemory;
begin
if Assigned(FMemory) then
Result:=FMemory
else
Result:= FModuleInstanceExports.Memory;
end;
function TPas2JSWASIEnvironment.fd_write(fd, iovs, iovsLen, nwritten: NativeInt): NativeInt;
var
@ -1089,6 +1304,11 @@ begin
Result:=WASI_ENOSYS;
end;
procedure TPas2JSWASIEnvironment.SetMemory(aMemory: TJSWebAssemblyMemory);
begin
FMemory:=aMemory;
end;
class constructor TPas2JSWASIEnvironment.init;
Var
Opts : TJSTextDecoderOptions;

35
packages/wasi/wasihostapp.pas
View File

@ -14,24 +14,27 @@ Type
TBrowserWASIHostApplication = class(TBrowserApplication)
private
FHost : TWASIHost;
FOnConsoleRead: TConsoleReadEvent;
FOnConsoleWrite: TConsoleWriteEvent;
FPredefinedConsoleInput: TStrings;
function GetAfterStart: TAfterStartEvent;
function GetBeforeStart: TBeforeStartEvent;
function GetEnv: TPas2JSWASIEnvironment;
function GetExported: TWASIExports;
function GetMemoryDescriptor: TJSWebAssemblyMemoryDescriptor;
function GetOnConsoleRead: TConsoleReadEvent;
function GetOnConsoleWrite: TConsoleWriteEvent;
function GetRunEntryFunction: String;
function GetTableDescriptor: TJSWebAssemblyTableDescriptor;
procedure SetAfterStart(AValue: TAfterStartEvent);
procedure SetBeforeStart(AValue: TBeforeStartEvent);
procedure SetMemoryDescriptor(AValue: TJSWebAssemblyMemoryDescriptor);
procedure SetOnConsoleRead(AValue: TConsoleReadEvent);
procedure SetOnConsoleWrite(AValue: TConsoleWriteEvent);
procedure SetPredefinedConsoleInput(AValue: TStrings);
procedure SetRunEntryFunction(AValue: String);
procedure SetTableDescriptor(AValue: TJSWebAssemblyTableDescriptor);
protected
function CreateHost: TWASIHost; virtual;
Property Host : TWASIHost Read FHost;
public
Constructor Create(aOwner : TComponent); override;
Destructor Destroy; override;
@ -56,9 +59,9 @@ Type
// Default console input
Property PredefinedConsoleInput : TStrings Read FPredefinedConsoleInput Write SetPredefinedConsoleInput;
// Called when reading from console (stdin). If not set, PredefinedConsoleinput is used.
property OnConsoleRead : TConsoleReadEvent Read FOnConsoleRead Write FOnConsoleRead;
property OnConsoleRead : TConsoleReadEvent Read GetOnConsoleRead Write SetOnConsoleRead;
// Called when writing to console (stdout). If not set, console.log is used.
property OnConsoleWrite : TConsoleWriteEvent Read FOnConsoleWrite Write FOnConsoleWrite;
property OnConsoleWrite : TConsoleWriteEvent Read GetOnConsoleWrite Write SetOnConsoleWrite;
end;
// For backwards compatibility
@ -94,6 +97,16 @@ begin
Result:=FHost.MemoryDescriptor;
end;
function TBrowserWASIHostApplication.GetOnConsoleRead: TConsoleReadEvent;
begin
Result:=FHost.OnConsoleRead;
end;
function TBrowserWASIHostApplication.GetOnConsoleWrite: TConsoleWriteEvent;
begin
Result:=FHost.OnConsoleWrite;
end;
function TBrowserWASIHostApplication.GetRunEntryFunction: String;
begin
Result:=FHost.RunEntryFunction;
@ -120,6 +133,18 @@ begin
FHost.MemoryDescriptor:=aValue;
end;
procedure TBrowserWASIHostApplication.SetOnConsoleRead(AValue: TConsoleReadEvent
);
begin
FHost.OnConsoleRead:=aValue
end;
procedure TBrowserWASIHostApplication.SetOnConsoleWrite(
AValue: TConsoleWriteEvent);
begin
FHost.OnConsoleWrite:=aValue;
end;
procedure TBrowserWASIHostApplication.SetPredefinedConsoleInput(AValue: TStrings);
begin
FHost.PredefinedConsoleInput:=aValue;
@ -139,7 +164,7 @@ end;
function TBrowserWASIHostApplication.CreateHost : TWASIHost;
begin
Result:=TWASIHost.Create(Nil);
Result:=TWASIHost.Create(Self);
end;
constructor TBrowserWASIHostApplication.Create(aOwner: TComponent);

613
packages/wasi/wasithreadedapp.pas Normal file
View File

@ -0,0 +1,613 @@
unit wasithreadedapp;
{$mode ObjFPC}
{$modeswitch externalclass}
{$modeswitch typehelpers}
interface
uses
JS, Classes, SysUtils, Rtl.WebThreads, wasienv, wasihostapp, weborworker;
Type
{ TWasmThread }
TWasmThread = TJSWorker;
{ TWasmThreadHelper }
TWasmThreadHelper = Class helper for TWasmThread
private
function GetLoaded: Boolean;
function GetLoadSent: Boolean;
function GetThreadID: Integer;
function GetThreadIDRange: Integer;
function GetThreadInfo: TThreadinfo;
function GetThreadLocation: Integer;
procedure SetLoaded(AValue: Boolean);
procedure SetLoadSent(AValue: Boolean);
procedure SetThreadID(AValue: Integer);
procedure SetThreadIDRange(AValue: Integer);
procedure SetThreadInfo(AValue: TThreadinfo);
procedure SetThreadLocation(AValue: Integer);
Public
Class function Create(aScript : String) : TWasmThread; reintroduce; static;
Procedure SendCommand(aCommand : TWorkerCommand);
Property LoadSent : Boolean Read GetLoadSent Write SetLoadSent;
Property Loaded : Boolean Read GetLoaded Write SetLoaded;
Property ThreadInfo : TThreadinfo Read GetThreadInfo Write SetThreadInfo;
Property ThreadID : Integer Read GetThreadID Write SetThreadID;
Property ThreadIDRange : Integer Read GetThreadIDRange Write SetThreadIDRange;
Property ThreadLocation : Integer Read GetThreadLocation Write SetThreadLocation;
end;
TThreadHash = class external name 'Object' (TJSObject)
Private
function GetThreadData(aIndex: NativeInt): TWasmThread; external name '[]';
procedure SetThreadData(aIndex: NativeInt; const AValue: TWasmThread); external name '[]';
Public
Property ThreadData[aIndex : NativeInt] : TWasmThread Read GetThreadData Write SetThreadData; default;
end;
// This object has the thread support that is needed by the 'main' program
{ TMainThreadSupport }
TMainThreadSupport = class(TWasmThreadSupport)
private
FInitialWorkerCount: Integer;
FMaxWorkerCount: Integer;
FOnUnknownMessage: TJSRawEventHandler;
FHost: TWASIHost;
FWorkerScript: String;
FNextIDRange : Integer;
FNextThreadID : Integer;
procedure SetWasiHost(AValue: TWASIHost);
Protected
Function thread_spawn(thread_id : Integer; attrs: Integer; thread_start_func : Integer; args : Integer) : Integer; override;
Function thread_detach(thread_id : Integer) : Integer; override;
Function thread_cancel(thread_id : Integer) : Integer; override;
Function thread_self() : Integer; override;
function AllocateThreadID : Integer;
Protected
FIdleWorkers : Array of TWasmThread;
FBusyWorkers : Array of TWasmThread;
FThreads : TThreadHash; // ThreadID is key,
// Send load commands to all workers that still need it.
procedure SendLoadCommands;
// Allocate new thread ID range
function GetNextThreadIDRange: Integer;
// Handle worker messages. If it is a command, it is set to handlecommand.
procedure DoWorkerMessage(aEvent: TJSEvent);
// Create & set up new worker
Function AllocateNewWorker(Const aWorkerScript : string) : TWasmThread;
// Send a load command
procedure SendLoadCommand(aThreadWorker: TWasmThread); virtual;
// Get new worker from pool, create new if needed.
Function GetNewWorker : TWasmThread;
// Spawn & prepare to run a new thread.
Function SpawnThread(aInfo : TThreadInfo) : Integer;
// Actually send run command.
Procedure SendRunCommand(aThreadWorker: TWasmThread);
//
// Handle Various commands sent from worker threads.
//
// Allocate a new worker for a thread and run the thread if the worker is loaded.
procedure HandleSpawnCommand(aWorker: TWasmThread; aCommand: TWorkerSpawnThreadCommand); virtual;
// Cancel command: stop the thread
procedure HandleCancelCommand(aWorker: TWasmThread; aCommand: TWorkerCancelCommand); virtual;
// Cleanup thread : after join (or stopped if detached), free worker.
procedure HandleCleanupCommand(aWorker: TWasmThread; aCommand: TWorkerCleanupCommand); virtual;
// forward KILL signal to thread.
procedure HandleKillCommand(aWorker: TWasmThread; aCommand: TWorkerKillCommand); virtual;
// Worker script is loaded, has loaded webassembly and is ready to run.
procedure HandleLoadedCommand(aWorker: TWasmThread; aCommand: TWorkerLoadedCommand); overload;
// Console output from worker.
procedure HandleConsoleCommand(aWorker: TWasmThread; aCommand: TWorkerConsoleCommand);
Public
Constructor Create(aEnv : TPas2JSWASIEnvironment); override;
Constructor Create(aEnv : TPas2JSWASIEnvironment; aWorkerScript : String; aSpawnWorkerCount : integer); virtual; overload;
Procedure HandleCommand(aWorker : TWasmThread; aCommand : TWorkerCommand); overload; virtual;
Property WorkerScript : String Read FWorkerScript;
// Initial number of threads, set by constructor
Property InitialWorkerCount : Integer Read FInitialWorkerCount;
// Maximum number of workers. If more workers are requested, the GetNewWorker will return Nil.
Property MaxWorkerCount : Integer Read FMaxWorkerCount Write FMaxWorkerCount;
Property OnUnknownMessage : TJSRawEventHandler Read FOnUnknownMessage Write FOnUnknownMessage;
// The WASI host, used to run routines.
Property Host : TWASIHost Read FHost Write SetWasiHost;
end;
{ TBrowserWASIThreadedHostApplication }
TBrowserWASIThreadedHostApplication = class(TBrowserWASIHostApplication)
private
FThreadSupport: TMainThreadSupport;
protected
Function CreateThreadSupport(aEnv : TPas2JSWASIEnvironment) : TMainThreadSupport; virtual;
Function CreateHost: TWASIHost; override;
Public
Destructor Destroy; override;
Property ThreadSupport : TMainThreadSupport Read FThreadSupport;
end;
{ ThreadAppWASIHost }
ThreadAppWASIHost = class(TWASIHost)
private
FThreadInitInstanceEntry: String;
FThreadSupport: TMainThreadSupport;
procedure SetThreadSupport(AValue: TMainThreadSupport);
Protected
Procedure PrepareWebAssemblyInstance(aDescr: TWebAssemblyStartDescriptor); override;
Procedure DoAfterInstantiate; override;
Public
constructor Create(aOwner: TComponent); override;
Property ThreadSupport : TMainThreadSupport Read FThreadSupport Write SetThreadSupport;
// Thread instance Init point name for the WASI Host.
Property ThreadInitInstanceEntry : String Read FThreadInitInstanceEntry Write FThreadInitInstanceEntry;
end;
implementation
Resourcestring
SErrMaxWorkersReached = 'Cannot create thread worker, Maximum number of workers (%d) reached.';
{ ThreadAppWASIHost }
procedure ThreadAppWASIHost.SetThreadSupport(AValue: TMainThreadSupport);
begin
if FThreadSupport=AValue then Exit;
FThreadSupport:=AValue;
FThreadSupport.Host:=Self;
end;
procedure ThreadAppWASIHost.PrepareWebAssemblyInstance(
aDescr: TWebAssemblyStartDescriptor);
Var
func : JSValue;
InitFunc : TThreadInitInstanceFunction absolute func;
Res : Integer;
begin
inherited;
Writeln('PrepareWebAssemblyInstance: check init thread');
func:=aDescr.Exported[ThreadInitInstanceEntry];
if Assigned(func) then
begin
Writeln('Initializing main thread instance');
res:=InitFunc(0,1,0);
if Res<>0 then
Writeln('Failed to initialize thread');
end;
end;
procedure ThreadAppWASIHost.DoAfterInstantiate;
begin
inherited DoAfterInstantiate;
If Assigned(FThreadSupport) then
FThreadSupport.SendLoadCommands;
end;
constructor ThreadAppWASIHost.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
ThreadInitInstanceEntry:=DefaultThreadInstanceInitPoint;
end;
{ TBrowserWASIThreadedHostApplication }
function TBrowserWASIThreadedHostApplication.CreateThreadSupport(
aEnv: TPas2JSWASIEnvironment): TMainThreadSupport;
begin
Result:=TMainThreadSupport.Create(aEnv);
end;
function TBrowserWASIThreadedHostApplication.CreateHost: TWASIHost;
Var
Res : ThreadAppWASIHost;
begin
Res:=ThreadAppWASIHost.Create(Self);
Res.UseSharedMemory:=True;
Res.ThreadSupport:=CreateThreadSupport(Res.WasiEnvironment);
Result:=Res;
end;
destructor TBrowserWASIThreadedHostApplication.Destroy;
begin
FreeAndNil(FThreadSupport);
inherited Destroy;
end;
{ TWasmThread }
class function TWasmThreadHelper.Create(aScript: String): TWasmThread;
begin
Result:=TJSWorker.new(aScript);
Result.ThreadID:=-1;
Result.Loaded:=False;
Result.LoadSent:=False;
Result.ThreadIDRange:=-1;
Result.ThreadInfo:=Default(TThreadInfo);
end;
function TWasmThreadHelper.GetLoaded: Boolean;
Var
S : JSValue;
begin
S:=Properties['FLoaded'];
if isBoolean(S) then
Result:=Boolean(S)
else
Result:=False;
end;
function TWasmThreadHelper.GetLoadSent: Boolean;
Var
S : JSValue;
begin
S:=Properties['FLoadSent'];
if isBoolean(S) then
Result:=Boolean(S)
else
Result:=False;
end;
function TWasmThreadHelper.GetThreadID: Integer;
begin
Result:=ThreadInfo.ThreadID;
end;
function TWasmThreadHelper.GetThreadIDRange: Integer;
Var
S : JSValue;
begin
S:=Properties['FThreadIDRange'];
if isNumber(S) then
Result:=Integer(S)
else
Result:=0;
end;
function TWasmThreadHelper.GetThreadInfo: TThreadinfo;
Var
S : JSValue;
begin
S:=Properties['FThreadInfo'];
if isObject(S) then
Result:=TThreadinfo(S)
else
Result:=Default(TThreadInfo);
end;
function TWasmThreadHelper.GetThreadLocation: Integer;
begin
Result:=ThreadInfo.ThreadInfoLocation;
end;
procedure TWasmThreadHelper.SetLoaded(AValue: Boolean);
begin
Properties['FLoaded']:=aValue
end;
procedure TWasmThreadHelper.SetLoadSent(AValue: Boolean);
begin
Properties['FLoadSent']:=aValue;
end;
procedure TWasmThreadHelper.SetThreadID(AValue: Integer);
begin
ThreadInfo.ThreadID:=aValue;
end;
procedure TWasmThreadHelper.SetThreadIDRange(AValue: Integer);
begin
Properties['FThreadIDRange']:=aValue
end;
procedure TWasmThreadHelper.SetThreadInfo(AValue: TThreadinfo);
begin
Properties['FThreadInfo']:=aValue
end;
procedure TWasmThreadHelper.SetThreadLocation(AValue: Integer);
begin
ThreadInfo.ThreadInfoLocation:=aValue
end;
procedure TWasmThreadHelper.SendCommand(aCommand: TWorkerCommand);
begin
// Writeln('Sending command '+TJSJSON.Stringify(aCommand));
PostMessage(aCommand);
end;
procedure TMainThreadSupport.DoWorkerMessage(aEvent: TJSEvent);
Var
aMessageEvent : TJSMessageEvent absolute aEvent;
aData : TWorkerCommand;
aWorker : TWasmThread;
begin
// Writeln('Received worker message '+TJSJSON.Stringify(aMessageEvent.Data));
if IsObject(aMessageEvent.Data) and TJSObject(aMessageEvent.Data).hasOwnProperty('Command') then
begin
aData:=TWorkerCommand(aMessageEvent.Data);
aWorker:=TWasmThread(aMessageEvent.Target);
HandleCommand(aWorker,aData);
end
else if Assigned(FOnUnknownMessage) then
FOnUnknownMessage(aEvent)
else
Writeln('Unknown worker message : ',TJSJSON.stringify(aEvent));
end;
function TMainThreadSupport.GetNextThreadIDRange : Integer;
begin
Inc(FNextIDRange,ThreadIDInterval);
Result:=FNextIDRange;
end;
function TMainThreadSupport.AllocateNewWorker(const aWorkerScript: string): TWasmThread;
begin
// Writeln('Allocating new worker for: '+aWorkerScript);
Result:=TWasmThread.Create(aWorkerScript);
Result.ThreadIDRange:=GetNextThreadIDRange;
Result.addEventListener('message',@DoWorkerMessage);
if Assigned(Host) and Host.StartDescriptorReady then
SendLoadCommand(Result)
else
Writeln('Host not set, delaying sending load command.'+aWorkerScript);
end;
procedure TMainThreadSupport.SendLoadCommand(aThreadWorker: TWasmThread);
Var
WLC: TWorkerLoadCommand;
begin
WLC:=TWorkerLoadCommand.Create(aThreadWorker.ThreadIDRange, Host.PreparedStartDescriptor.Module, Host.PreparedStartDescriptor.Memory);
aThreadWorker.SendCommand(WLC);
aThreadWorker.LoadSent:=True;
end;
function TMainThreadSupport.GetNewWorker: TWasmThread;
Var
WT : TWasmThread;
begin
if Length(FIdleWorkers)=0 then
begin
// Writeln('No idle workers, creating new one');
if Length(FBusyWorkers)<MaxWorkerCount then
WT:=AllocateNewWorker(FWorkerScript)
else
Raise EWasmThreads.Create(SErrMaxWorkersReached);
end
else
begin
WT:=TWasmThread(TJSArray(FIdleWorkers).pop);
end;
TJSArray(FBusyWorkers).Push(WT);
Result:=WT;
end;
procedure TMainThreadSupport.SendRunCommand(aThreadWorker: TWasmThread);
Var
WRC : TWorkerRunCommand;
begin
With aThreadWorker.ThreadInfo do
WRC:=TWorkerRunCommand.Create(ThreadID,RunFunction,Attributes,Arguments,ThreadInfoLocation);
aThreadWorker.SendCommand(Wrc);
end;
procedure TMainThreadSupport.SetWasiHost(AValue: TWASIHost);
begin
// Writeln('Setting wasi host');
if FHost=AValue then
Exit;
FHost:=AValue;
If Assigned(FHost) and Host.StartDescriptorReady then
SendLoadCommands;
end;
function TMainThreadSupport.thread_spawn(thread_id: Integer; attrs: Integer;
thread_start_func: Integer; args: Integer): Integer;
var
aInfo : TThreadInfo;
begin
// Writeln('In host thread_spawn');
aInfo.ThreadID:=AllocateThreadID;
aInfo.RunFunction:=thread_start_func;
aInfo.Arguments:=Args;
aInfo.Attributes:=Attrs;
aInfo.OriginThreadID:=0;
aInfo.ThreadInfoLocation:=thread_id;
Env.SetMemInfoInt32(thread_id,aInfo.ThreadID);
Result:=SpawnThread(aInfo);
end;
function TMainThreadSupport.thread_detach(thread_id: Integer): Integer;
begin
Result:=0;
end;
function TMainThreadSupport.thread_cancel(thread_id: Integer): Integer;
begin
Result:=0;
end;
function TMainThreadSupport.thread_self: Integer;
begin
Result:=0;
end;
function TMainThreadSupport.AllocateThreadID: Integer;
begin
Inc(FNextThreadID);
Result:=FNextThreadID;
end;
procedure TMainThreadSupport.SendLoadCommands;
Var
WT : TWasmThread;
begin
// Writeln('Sending load command to all workers');
For WT in FIdleWorkers do
if not WT.LoadSent then
SendLoadCommand(WT);
end;
function TMainThreadSupport.SpawnThread(aInfo: TThreadInfo): Integer;
Var
WT : TWasmThread;
begin
// Writeln('Enter TMainThreadSupport.SpawnThread for ID ',aInfo.ThreadID);
WT:=GetNewWorker;
if WT=nil then
begin
Writeln('Error: no worker !');
exit(-1)
end;
WT.ThreadInfo:=aInfo;
FThreads[aInfo.ThreadID]:=WT;
if WT.Loaded then
begin
// Writeln('Worker is loaded. Sending run command to worker');
SendRunCommand(WT);
end;
// Writeln('Exit: TMainThreadSupport.SpawnThread for ID ',WT.ThreadID);
end;
constructor TMainThreadSupport.Create(aEnv: TPas2JSWASIEnvironment);
begin
Create(aEnv,DefaultThreadWorker,DefaultThreadCount)
end;
constructor TMainThreadSupport.Create(aEnv: TPas2JSWASIEnvironment;
aWorkerScript: String; aSpawnWorkerCount: integer);
Var
I : Integer;
begin
Inherited Create(aEnv);
FThreads:=TThreadHash.new;
FWorkerScript:=aWorkerScript;
FInitialWorkerCount:=aSpawnWorkerCount;
FMaxWorkerCount:=DefaultMaxWorkerCount;
For I:=1 to aSpawnWorkerCount do
TJSArray(FIdleWorkers).Push(AllocateNewWorker(aWorkerScript));
end;
procedure TMainThreadSupport.HandleSpawnCommand(aWorker : TWasmThread; aCommand: TWorkerSpawnThreadCommand);
Var
aInfo: TThreadInfo;
begin
aInfo.OriginThreadID:=aWorker.ThreadID;
aInfo.RunFunction:=aCommand.RunFunction;
aInfo.ThreadID:=aCommand.ThreadID;
aInfo.Arguments:=aCommand.Arguments;
aInfo.Attributes:=aCommand.Attributes;
SpawnThread(aInfo);
end;
procedure TMainThreadSupport.HandleKillCommand(aWorker : TWasmThread; aCommand: TWorkerKillCommand);
begin
end;
procedure TMainThreadSupport.HandleCancelCommand(aWorker : TWasmThread; aCommand: TWorkerCancelCommand);
begin
end;
procedure TMainThreadSupport.HandleLoadedCommand(aWorker : TWasmThread; aCommand: TWorkerLoadedCommand);
begin
// Writeln('Host: Entering TMainThreadSupport.HandleLoadedCommand');
aWorker.Loaded:=True;
// if a thread is scheduled to run in this thread, run it.
if aWorker.ThreadID>0 then
SendRunCommand(aWorker);
// Writeln('Host: exiting TMainThreadSupport.HandleLoadedCommand');
end;
procedure TMainThreadSupport.HandleCleanupCommand(aWorker : TWasmThread; aCommand: TWorkerCleanupCommand);
Var
Idx : Integer;
begin
aWorker.ThreadInfo:=Default(TThreadInfo);
Idx:=TJSarray(FBusyWorkers).indexOf(aWorker);
if Idx<>-1 then
Delete(FBusyWorkers,Idx,1);
Idx:=TJSarray(FIdleWorkers).indexOf(aWorker);
if Idx=-1 then
FIdleWorkers:=Concat(FIdleWorkers,[aWorker]);
end;
procedure TMainThreadSupport.HandleConsoleCommand(aWorker : TWasmThread; aCommand: TWorkerConsoleCommand);
Var
Prefix : string;
begin
Prefix:=Format('Wasm thread %d: ',[aWorker.ThreadID]);
if Assigned(Host.OnConsoleWrite) then
Host.OnConsoleWrite(Host,Prefix+aCommand.ConsoleMessage)
else
Writeln(Prefix+aCommand.ConsoleMessage);
end;
procedure TMainThreadSupport.HandleCommand(aWorker : TWasmThread; aCommand: TWorkerCommand);
begin
Case aCommand.Command of
cmdSpawn : HandleSpawnCommand(aWorker, TWorkerSpawnThreadCommand(aCommand));
cmdCleanup : HandleCleanupCommand(aWorker, TWorkerCleanupCommand(aCommand));
cmdKill : HandleKillCommand(aWorker, TWorkerKillCommand(aCommand));
cmdCancel : HandleCancelCommand(aWorker, TWorkerCancelCommand(aCommand));
cmdLoaded : HandleLoadedCommand(aWorker, TWorkerLoadedCommand(aCommand));
cmdConsole : HandleConsoleCommand(aWorker, TWorkerConsoleCommand(aCommand));
else
HandleCommand(aCommand);
end;
end;
end.

663
packages/wasi/wasiworkerthreadhost.pas Normal file
View File

@ -0,0 +1,663 @@
unit wasiworkerthreadhost;
{$mode ObjFPC}
{$modeswitch externalclass}
interface
uses
Classes, SysUtils, JS, custapp, weborworker, webworker, webassembly, wasienv, Rtl.WebThreads;
Type
TWorkerThreadSupport = Class;
{ TWASIThreadHost }
TWASIThreadHost = class(TWASIHost)
private
FSendOutputToBrowserWindow: Boolean;
FThreadEntryPoint: String;
FThreadInitInstanceEntry : String;
FThreadSupport: TWorkerThreadSupport;
procedure SetThreadSupport(AValue: TWorkerThreadSupport);
Protected
Procedure RunWebAssemblyThread(aProc : TRunWebassemblyProc); virtual;
Procedure PrepareWebAssemblyThread(aDescr : TWebAssemblyStartDescriptor); virtual;
procedure DoStdWrite(Sender: TObject; const aOutput: String); override;
Public
constructor Create(aOwner: TComponent); override;
// Thread entry point name for the WASI Host.
Property ThreadEntryPoint : String Read FThreadEntryPoint Write FThreadEntryPoint;
// Thread instance Init point name for the WASI Host.
Property ThreadInitInstanceEntry : String Read FThreadInitInstanceEntry Write FThreadInitInstanceEntry;
// Send output to main window
Property SendOutputToBrowserWindow : Boolean Read FSendOutputToBrowserWindow Write FSendOutputToBrowserWindow;
// our thread
Property ThreadSupport : TWorkerThreadSupport Read FThreadSupport Write SetThreadSupport;
end;
// This object has the thread support that is needed by the worker that runs a thread.
{ TWorkerThreadSupport }
TWorkerThreadSupport = class(TWasmThreadSupport)
Private
FStartThreadID : Integer;
FNextThreadID : Integer;
FCurrentThreadInfo : TThreadinfo;
FModule : TJSWebAssemblyModule;
FMemory : TJSWebAssemblyMemory;
FWasiHost: TWASIThreadHost;
Protected
// Set new thread range
procedure InitThreadRange(aRange: Integer);
// allocate new thread ID.
Function AllocateNewThreadID : NativeInt;
// Incoming messages
procedure LoadWasmModule(aCommand: TWorkerLoadCommand); virtual;
procedure RunWasmModule(aCommand: TWorkerRunCommand); virtual;
procedure CancelWasmModule(aCommand: TWorkerCancelCommand); virtual;
procedure SetThreadRange(aCommand: TWorkerThreadIDRangeCommand); virtual;
// outgoing messages
procedure RequestNewThreadBlock; virtual;
procedure SendLoaded; virtual;
Procedure SendConsoleMessage(aMessage : String); overload;
Procedure SendConsoleMessage(aFmt : String; const aArgs : array of const); overload;
Procedure SendConsoleMessage(const aArgs : array of JSValue); overload;
procedure SendException(aError: Exception); overload;
procedure SendException(aError: TJSError); overload;
Protected
Function thread_spawn(thread_id : Integer; attrs: Integer; thread_start_func : Integer; args : Integer) : Integer; override;
Function thread_detach(thread_id : Integer) : Integer; override;
Function thread_cancel(thread_id : Integer) : Integer; override;
Function thread_self() : Integer; override;
Public
// Handle incoming command
Procedure HandleCommand(aCommand : TWorkerCommand); override;
// Current thread info.
Property CurrentThreadInfo : TThreadInfo Read FCurrentThreadInfo;
// The WASI host, used to run routines.
Property Host : TWASIThreadHost Read FWasiHost Write FWasiHost;
end;
{ TWorkerWASIHostApplication }
TWorkerWASIHostApplication = class(TCustomApplication)
private
FHost : TWASIHost;
FThreadSupport : TWorkerThreadSupport;
FSendOutputToBrowser: Boolean;
function GetAfterStart: TAfterStartEvent;
function GetBeforeStart: TBeforeStartEvent;
function GetcPredefinedConsoleInput: TStrings;
function GetEnv: TPas2JSWASIEnvironment;
function GetExported: TWASIExports;
function GetOnConsoleRead: TConsoleReadEvent;
function GetOnConsoleWrite: TConsoleWriteEvent;
function GetRunEntryFunction: String;
procedure SetAfterStart(AValue: TAfterStartEvent);
procedure SetBeforeStart(AValue: TBeforeStartEvent);
procedure SetOnConsoleRead(AValue: TConsoleReadEvent);
procedure SetOnConsoleWrite(AValue: TConsoleWriteEvent);
procedure SetPredefinedConsoleInput(AValue: TStrings);
procedure SetRunEntryFunction(AValue: String);
protected
procedure HandleMessage(aEvent: TJSEvent); virtual;
procedure DoOnSendCommand(Sender : TObject; aCommand : TWorkerCommand);
function CreateHost: TWASIHost; virtual;
procedure DoRun; override;
function GetConsoleApplication: boolean; override;
function GetLocation: String; override;
public
Constructor Create(aOwner : TComponent); override;
Destructor Destroy; override;
procedure SendCommand(aCommand: TWorkerCommand); virtual;
procedure GetEnvironmentList(List: TStrings; NamesOnly: Boolean); override;
procedure ShowException(E: Exception); override;
// Load and start webassembly. If DoRun is true, then Webassembly entry point is called.
// If aBeforeStart is specified, then it is called prior to calling run, and can disable running.
// If aAfterStart is specified, then it is called after calling run. It is not called is running was disabled.
Procedure StartWebAssembly(aPath: string; DoRun : Boolean = True; aBeforeStart : TBeforeStartCallback = Nil; aAfterStart : TAfterStartCallback = Nil);
// Environment to be used
Property WasiEnvironment : TPas2JSWASIEnvironment Read GetEnv;
// Exported functions. Also available in start descriptor.
Property Exported : TWASIExports Read GetExported;
// Name of function to run, if empty default _start symbol is used.
Property RunEntryFunction : String Read GetRunEntryFunction Write SetRunEntryFunction;
// Called after webassembly start was run. Not called if webassembly was not run.
Property AfterStart : TAfterStartEvent Read GetAfterStart Write SetAfterStart;
// Called before running webassembly. If aAllowRun is false, running is disabled
Property BeforeStart : TBeforeStartEvent Read GetBeforeStart Write SetBeforeStart;
// Send output to browser window process?
Property SendOutputToBrowser : Boolean Read FSendOutputToBrowser Write FSendOutputToBrowser;
// Default console input
Property PredefinedConsoleInput : TStrings Read GetcPredefinedConsoleInput Write SetPredefinedConsoleInput;
// Called when reading from console (stdin). If not set, PredefinedConsoleinput is used.
property OnConsoleRead : TConsoleReadEvent Read GetOnConsoleRead Write SetOnConsoleRead;
// Called when writing to console (stdout). If not set, console.log is used.
property OnConsoleWrite : TConsoleWriteEvent Read GetOnConsoleWrite Write SetOnConsoleWrite;
// Our thread support object
Property ThreadSupport : TWorkerThreadSupport Read FThreadSupport Write FThreadSupport;
end;
implementation
uses Types;
var
Self_ : TJSDedicatedWorkerGlobalScope; external name 'self';
EnvNames: TJSObject;
procedure ReloadEnvironmentStrings;
var
I : Integer;
S,N : String;
A,P : TStringDynArray;
begin
if Assigned(EnvNames) then
FreeAndNil(EnvNames);
EnvNames:=TJSObject.new;
S:=self_.Location.search;
S:=Copy(S,2,Length(S)-1);
A:=TJSString(S).split('&');
for I:=0 to Length(A)-1 do
begin
P:=TJSString(A[i]).split('=');
N:=LowerCase(decodeURIComponent(P[0]));
if Length(P)=2 then
EnvNames[N]:=decodeURIComponent(P[1])
else if Length(P)=1 then
EnvNames[N]:=''
end;
end;
function MyGetEnvironmentVariable(Const EnvVar: String): String;
Var
aName : String;
begin
aName:=Lowercase(EnvVar);
if EnvNames.hasOwnProperty(aName) then
Result:=String(EnvNames[aName])
else
Result:='';
end;
function MyGetEnvironmentVariableCount: Integer;
begin
Result:=length(TJSOBject.getOwnPropertyNames(envNames));
end;
function MyGetEnvironmentString(Index: Integer): String;
begin
Result:=String(EnvNames[TJSOBject.getOwnPropertyNames(envNames)[Index]]);
end;
{ TWASIThreadHost }
procedure TWASIThreadHost.SetThreadSupport(AValue: TWorkerThreadSupport);
begin
if FThreadSupport=AValue then Exit;
if Assigned(FThreadSupport) then
FThreadSupport.Host:=Nil;
FThreadSupport:=AValue;
if Assigned(FThreadSupport) then
FThreadSupport.Host:=Self;
end;
procedure TWASIThreadHost.RunWebAssemblyThread(aProc : TRunWebassemblyProc);
begin
// Writeln('TWASIThreadHost.Entering RunWebAssemblyThread ');
RunWebAssemblyInstance(Nil,Nil,aProc);
end;
procedure TWASIThreadHost.PrepareWebAssemblyThread( aDescr: TWebAssemblyStartDescriptor);
Var
func : JSValue;
InitFunc : TThreadInitInstanceFunction absolute func;
res : Integer;
begin
PrepareWebAssemblyInstance(aDescr);
func:=aDescr.Exported[ThreadInitInstanceEntry];
if Assigned(func) then
begin
res:=InitFunc(1,0,1);
if Res<>0 then
if Assigned(ThreadSupport) then
ThreadSupport.SendConsoleMessage('Could not init assembly thread: %d', [Res])
else
Writeln('Could not init assembly thread: ',Res);
end;
end;
procedure TWASIThreadHost.DoStdWrite(Sender: TObject; const aOutput: String);
begin
inherited DoStdWrite(Sender, aOutput);
if FSendOutputToBrowserWindow and assigned(FThreadSupport) then
FThreadSupport.SendConsoleMessage(aOutput);
end;
constructor TWASIThreadHost.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
FThreadEntryPoint:=DefaultThreadEntryPoint;
FThreadInitInstanceEntry:=DefaultThreadInstanceInitPoint;
FSendOutputToBrowserWindow:=True;
end;
{ TWorkerThreadSupport }
function TWorkerThreadSupport.thread_spawn(thread_id: Integer; attrs: Integer;
thread_start_func: Integer; args: Integer): Integer;
Var
P : TWorkerSpawnThreadCommand;
begin
P:=TWorkerSpawnThreadCommand.Create(AllocateNewThreadID,Attrs,Args,thread_start_func,Thread_id);
SendCommand(P);
Env.SetMemInfoInt32(thread_id,P.ThreadID);
Result:=0;
end;
function TWorkerThreadSupport.thread_detach(thread_id: Integer): Integer;
begin
Result:=0;
end;
function TWorkerThreadSupport.thread_cancel(thread_id: Integer): Integer;
begin
Result:=0;
end;
function TWorkerThreadSupport.thread_self: Integer;
begin
Result:=0;
end;
function TWorkerThreadSupport.AllocateNewThreadID: NativeInt;
begin
if (FNextThreadID-FStartThreadID)>=ThreadIDInterval then
FNextThreadID:=FStartThreadID;
Inc(FNextThreadID);
if (FNextThreadID-FStartThreadID)=ThreadIDInterval-ThreadIDMargin then
RequestNewThreadBlock;
Result:=FNextThreadID;
end;
procedure TWorkerThreadSupport.SendLoaded;
Var
L : TWorkerLoadedCommand;
begin
L:=TWorkerLoadedCommand.Create();
SendCommand(L);
end;
procedure TWorkerThreadSupport.SendConsoleMessage(aMessage: String);
Var
L : TWorkerConsoleCommand;
begin
L:=TWorkerConsoleCommand.Create(aMessage,FCurrentThreadInfo.ThreadId);
SendCommand(L);
end;
procedure TWorkerThreadSupport.SendConsoleMessage(aFmt: String;
const aArgs: array of const);
begin
SendConsoleMessage(Format(aFmt,aArgs));
end;
procedure TWorkerThreadSupport.SendConsoleMessage(const aArgs: array of JSValue);
Var
L : TWorkerConsoleCommand;
begin
L:=TWorkerConsoleCommand.Create(aArgs,FCurrentThreadInfo.ThreadId);
SendCommand(L);
end;
procedure TWorkerThreadSupport.CancelWasmModule(aCommand : TWorkerCancelCommand);
begin
// todo
end;
procedure TWorkerThreadSupport.SendException(aError : Exception);
Var
E : TWorkerExceptionCommand;
begin
E:=TWorkerExceptionCommand.CreateNew(aError.ClassName,aError.Message,FCurrentThreadInfo.ThreadId);
SendCommand(E);
end;
procedure TWorkerThreadSupport.SendException(aError: TJSError);
Var
aMessage,aClass : String;
E : TWorkerExceptionCommand;
begin
aClass:='Error';
aMessage:=aError.Message;
E:=TWorkerExceptionCommand.CreateNew(aClass,aMessage,FCurrentThreadInfo.ThreadId);
SendCommand(E);
end;
procedure TWorkerThreadSupport.RunWasmModule(aCommand : TWorkerRunCommand);
Procedure DoRun (aExports : TWASIExports);
Var
aResult : Integer;
begin
try
// Writeln('About to run webassembly entry point (',Host.ThreadEntryPoint,') for thread ID ',aCommand.ThreadID);
aResult:=TThreadEntryPointFunction(aExports[Host.ThreadEntryPoint])(aCommand.ThreadInfo,aCommand.RunThreadProc, aCommand.args);
if aResult>0 then
Writeln('Thread run function result ',aResult);
except
on E : Exception do
SendException(E);
on JE : TJSError do
SendException(JE);
on JE : TJSError do
SendException(JE)
end;
end;
begin
// Writeln('Entering TWorkerThreadSupport.RunWasmModule '+TJSJSON.Stringify(aCommand));
// initialize current thread info
FCurrentThreadInfo.ThreadID:=aCommand.ThreadID;
FCurrentThreadInfo.Arguments:=aCommand.Args;
FCurrentThreadInfo.ThreadInfoLocation:=aCommand.ThreadInfo;
FCurrentThreadInfo.Attributes:=aCommand.Attrs;
FCurrentThreadInfo.RunFunction:=aCommand.RunThreadProc;
Host.RunWebAssemblyThread(@DoRun);
end;
procedure TWorkerThreadSupport.LoadWasmModule(aCommand: TWorkerLoadCommand);
Var
WASD : TWebAssemblyStartDescriptor;
aTable : TJSWebAssemblyTable;
function doOK(aValue: JSValue): JSValue;
// We are using the overload that takes a compiled module.
// In that case the promise resolves to a WebAssembly.Instance, not to a InstantiateResult !
Var
aInstance : TJSWebAssemblyInstance absolute aValue;
begin
Result:=True;
WASD.Instance:=aInstance;
WASD.Exported:=TWASIExports(TJSObject(aInstance.exports_));
WASD.CallRun:=Nil;
Host.PrepareWebAssemblyThread(WASD);
SendLoaded;
// These 2 prevent running different instances simultaneously.
end;
function DoFail(aValue: JSValue): JSValue;
var
E: Exception;
begin
Result:=True;
E:=Exception.Create('Failed to create webassembly. Reason: '+TJSJSON.Stringify(aValue));
SendException(E);
E.Free;
end;
begin
FMemory:=aCommand.Memory;
FModule:=aCommand.Module;
InitThreadRange(aCommand.ThreadRangeStart);
try
aTable:=TJSWebAssemblyTable.New(Host.TableDescriptor);
WASD:=Host.InitStartDescriptor(FMemory,aTable,Nil);
TJSWebAssembly.Instantiate(FModule,WASD.Imports)._then(@DoOK,@DoFail).Catch(@DoFail);
except
on E : Exception do
SendException(E);
on JE : TJSError do
SendException(JE);
end;
end;
procedure TWorkerThreadSupport.InitThreadRange(aRange: Integer);
begin
FStartThreadID:=aRange;
FNextThreadID:=FStartThreadID;
end;
procedure TWorkerThreadSupport.RequestNewThreadBlock;
begin
SendCommand(TWorkerNeedIdBlockCommand.Create(FNextThreadID));
end;
procedure TWorkerThreadSupport.SetThreadRange(
aCommand: TWorkerThreadIDRangeCommand);
begin
InitThreadRange(aCommand.RangeStart);
end;
procedure TWorkerThreadSupport.HandleCommand(aCommand: TWorkerCommand);
begin
case aCommand.Command of
cmdload : LoadWasmModule(TWorkerLoadCommand(aCommand));
cmdRun : RunWasmModule(TWorkerRunCommand(aCommand));
cmdCancel : CancelWasmModule(TWorkerCancelCommand(aCommand));
cmdThreadIdRange : SetThreadRange(TWorkerThreadIDRangeCommand(aCommand));
end;
end;
{ TWorkerWASIHostApplication }
function TWorkerWASIHostApplication.GetAfterStart: TAfterStartEvent;
begin
Result:=FHost.AfterStart;
end;
function TWorkerWASIHostApplication.GetBeforeStart: TBeforeStartEvent;
begin
Result:=FHost.BeforeStart;
end;
function TWorkerWASIHostApplication.GetcPredefinedConsoleInput: TStrings;
begin
Result:=FHost.PredefinedConsoleInput;
end;
function TWorkerWASIHostApplication.GetEnv: TPas2JSWASIEnvironment;
begin
Result:=FHost.WasiEnvironment;
end;
function TWorkerWASIHostApplication.GetExported: TWASIExports;
begin
Result:=FHost.Exported;
end;
function TWorkerWASIHostApplication.GetOnConsoleRead: TConsoleReadEvent;
begin
Result:=FHost.OnConsoleRead;
end;
function TWorkerWASIHostApplication.GetOnConsoleWrite: TConsoleWriteEvent;
begin
Result:=FHost.OnConsoleWrite;
end;
function TWorkerWASIHostApplication.GetRunEntryFunction: String;
begin
Result:=FHost.RunEntryFunction;
end;
procedure TWorkerWASIHostApplication.SetAfterStart(AValue: TAfterStartEvent);
begin
FHost.AfterStart:=aValue;
end;
procedure TWorkerWASIHostApplication.SetBeforeStart(AValue: TBeforeStartEvent);
begin
FHost.BeforeStart:=aValue;
end;
procedure TWorkerWASIHostApplication.SetOnConsoleRead(AValue: TConsoleReadEvent
);
begin
FHost.OnConsoleRead:=aValue;
end;
procedure TWorkerWASIHostApplication.SetOnConsoleWrite(
AValue: TConsoleWriteEvent);
begin
FHost.OnConsoleWrite:=aValue;
end;
procedure TWorkerWASIHostApplication.SetPredefinedConsoleInput(AValue: TStrings);
begin
FHost.PredefinedConsoleInput:=aValue;
end;
procedure TWorkerWASIHostApplication.SetRunEntryFunction(AValue: String);
begin
FHost.RunEntryFunction:=aValue;
end;
function TWorkerWASIHostApplication.CreateHost : TWASIHost;
Var
TH : TWasiThreadHost;
begin
TH:=TWASIThreadHost.Create(Self);
FThreadSupport:=TWorkerThreadSupport.Create(TH.WasiEnvironment);
FThreadSupport.OnSendCommand:=@DoOnSendCommand;
TH.ThreadSupport:=FThreadSupport; // Sets FThreadSupport.host
Result:=TH;
end;
procedure TWorkerWASIHostApplication.DoRun;
begin
Self_.addEventListener('message',@HandleMessage);
end;
procedure TWorkerWASIHostApplication.HandleMessage(aEvent: TJSEvent);
Var
aMessageEvent : TJSMessageEvent absolute aEvent;
aData : TWorkerCommand;
begin
if IsObject(aMessageEvent.Data) and TJSObject(aMessageEvent.Data).hasOwnProperty('Command') then
begin
aData:=TWorkerCommand(aMessageEvent.Data);
FThreadSupport.HandleCommand(aData);
end
else
FThreadSupport.SendConsoleMessage('Unknown message received: '+TJSJSON.Stringify(aMessageEvent.Data));
end;
procedure TWorkerWASIHostApplication.DoOnSendCommand(Sender: TObject;
aCommand: TWorkerCommand);
begin
SendCommand(aCommand);
end;
procedure TWorkerWASIHostApplication.SendCommand(aCommand: TWorkerCommand);
begin
Self_.PostMessage(aCommand);
end;
function TWorkerWASIHostApplication.GetConsoleApplication: boolean;
begin
Result:=true;
end;
function TWorkerWASIHostApplication.GetLocation: String;
begin
Result:=webworker.Location.pathname;
end;
constructor TWorkerWASIHostApplication.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
FHost:=CreateHost;
end;
destructor TWorkerWASIHostApplication.Destroy;
begin
FreeAndNil(FHost);
inherited Destroy;
end;
procedure TWorkerWASIHostApplication.GetEnvironmentList(List: TStrings;
NamesOnly: Boolean);
var
Names: TStringDynArray;
i: Integer;
begin
Names:=TJSObject.getOwnPropertyNames(EnvNames);
for i:=0 to length(Names)-1 do
begin
if NamesOnly then
List.Add(Names[i])
else
List.Add(Names[i]+'='+String(EnvNames[Names[i]]));
end;
end;
procedure TWorkerWASIHostApplication.ShowException(E: Exception);
begin
ThreadSupport.SendException(E);
end;
procedure TWorkerWASIHostApplication.StartWebAssembly(aPath: string; DoRun: Boolean;
aBeforeStart: TBeforeStartCallback = nil; aAfterStart: TAfterStartCallback = nil);
begin
FHost.StartWebAssembly(aPath,DoRun,aBeforeStart,aAfterStart);
end;
Initialization
ReloadEnvironmentStrings;
OnGetEnvironmentVariable:=@MyGetEnvironmentVariable;
OnGetEnvironmentVariableCount:=@MyGetEnvironmentVariableCount;
OnGetEnvironmentString:=@MyGetEnvironmentString;
end.