+ added except_exnref.inc (RTL support for WebAssembly exnref exceptions)

rtl/inc/objpas.inc

@@ -1398,7 +1398,9 @@ end;
 ****************************************************************************}
 
 {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
-  {$if defined(FPC_WASM_NATIVE_EXCEPTIONS)}
+  {$if defined(FPC_WASM_EXNREF_EXCEPTIONS)}
+    {$I except_exnref.inc}
+  {$elseif defined(FPC_WASM_NATIVE_EXCEPTIONS)}
     {$I except_native.inc}
   {$elseif defined(FPC_WASM_BRANCHFUL_EXCEPTIONS)}
     {$I except_branchful.inc}

rtl/wasm32/except_exnref.inc

@@ -0,0 +1,350 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Michael Van Canneyt
+    member of the Free Pascal development team
+
+    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.
+
+ **********************************************************************}
+
+{****************************************************************************
+                                Exception support
+****************************************************************************}
+
+
+{$ifdef FPC_HAS_FEATURE_THREADING}
+ThreadVar
+{$else FPC_HAS_FEATURE_THREADING}
+Var
+{$endif FPC_HAS_FEATURE_THREADING}
+  ExceptObjectStack : PExceptObject;
+  ExceptTryLevel    : ObjpasInt;
+
+{$ifdef FPC_USE_PSABIEH}
+{$i psabieh.inc}
+{$endif}
+
+Function RaiseList : PExceptObject;
+begin
+  RaiseList:=ExceptObjectStack;
+end;
+
+
+function AcquireExceptionObject: Pointer;
+var
+  _ExceptObjectStack : PExceptObject;
+begin
+  _ExceptObjectStack:=ExceptObjectStack;
+  If _ExceptObjectStack<>nil then
+    begin
+      Inc(_ExceptObjectStack^.refcount);
+      AcquireExceptionObject := _ExceptObjectStack^.FObject;
+    end
+  else
+    RunError(231);
+end;
+
+
+procedure ReleaseExceptionObject;
+var
+  _ExceptObjectStack : PExceptObject;
+begin
+  _ExceptObjectStack:=ExceptObjectStack;
+  If _ExceptObjectStack <> nil then
+    begin
+      if _ExceptObjectStack^.refcount > 0 then
+        Dec(_ExceptObjectStack^.refcount);
+    end
+  else
+    RunError(231);
+end;
+
+
+{ This routine is called only from fpc_raiseexception, which uses ExceptTryLevel
+  flag to guard against repeated exceptions which can occur due to corrupted stack
+  or heap. }
+function PushExceptObject(Obj : TObject; AnAddr : CodePointer; AFrame : Pointer): PExceptObject;
+var
+  Newobj : PExceptObject;
+  _ExceptObjectStack : ^PExceptObject;
+  framebufsize,
+  framecount  : PtrInt;
+  frames      : PCodePointer;
+  prev_frame,
+  curr_frame  : Pointer;
+  curr_addr   : CodePointer;
+begin
+{$ifdef excdebug}
+  writeln ('In PushExceptObject');
+{$endif}
+  _ExceptObjectStack:=@ExceptObjectStack;
+  NewObj:=AllocMem(sizeof(TExceptObject));
+  NewObj^.Next:=_ExceptObjectStack^;
+  _ExceptObjectStack^:=NewObj;
+
+  NewObj^.FObject:=Obj;
+  NewObj^.Addr:=AnAddr;
+  if assigned(get_frame) then
+    begin
+      NewObj^.refcount:=0;
+
+      { Backtrace }
+      curr_frame:=AFrame;
+      curr_addr:=AnAddr;
+      frames:=nil;
+      framecount:=0;
+      framebufsize:=0;
+      { The frame pointer of this procedure is used as initial stack bottom value. }
+      prev_frame:=get_frame;
+      while (framecount<RaiseMaxFrameCount) and (curr_frame > prev_frame) and
+            (curr_frame<StackTop) do
+        Begin
+          prev_frame:=curr_frame;
+          get_caller_stackinfo(curr_frame,curr_addr);
+          if (curr_addr=nil) or
+             (curr_frame=nil) then
+            break;
+          if (framecount>=framebufsize) then
+            begin
+              inc(framebufsize,16);
+              reallocmem(frames,framebufsize*sizeof(codepointer));
+            end;
+          frames[framecount]:=curr_addr;
+          inc(framecount);
+        End;
+      NewObj^.framecount:=framecount;
+      NewObj^.frames:=frames;
+    end;
+  Result:=NewObj;
+end;
+
+Procedure DoUnHandledException;[Public, Alias : 'FPC_DOUNHANDLEDEXCEPTION'];
+var
+  _ExceptObjectStack : PExceptObject;
+begin
+  _ExceptObjectStack:=ExceptObjectStack;
+  If (ExceptProc<>Nil) and (_ExceptObjectStack<>Nil) then
+    with _ExceptObjectStack^ do
+      begin
+        TExceptProc(ExceptProc)(FObject,Addr,FrameCount,Frames);
+        halt(217)
+      end;
+  if erroraddr = nil then
+    RunError(217)
+  else
+    Halt(errorcode);
+end;
+
+{$ifndef FPC_SYSTEM_HAS_RAISEEXCEPTION}
+procedure fpc_RaiseException (Obj : TObject; AnAddr : CodePointer; AFrame : Pointer);[Public, Alias : 'FPC_RAISEEXCEPTION']; compilerproc;
+var
+  _ExceptObjectStack : PExceptObject;
+  _ExceptAddrstack : PExceptAddr;
+begin
+{$ifdef excdebug}
+  writeln ('In RaiseException');
+{$endif}
+  if ExceptTryLevel<>0 then
+    Halt(217);
+  ExceptTryLevel:=1;
+  PushExceptObject(Obj,AnAddr,AFrame);
+  { if PushExceptObject causes another exception, the following won't be executed,
+    causing halt upon entering this routine recursively. }
+  ExceptTryLevel:=0;
+//  _ExceptAddrstack:=ExceptAddrStack;
+//  If _ExceptAddrStack=Nil then
+//    DoUnhandledException;
+  _ExceptObjectStack:=ExceptObjectStack;
+  if (RaiseProc <> nil) and (_ExceptObjectStack <> nil) then
+    with _ExceptObjectStack^ do
+      RaiseProc(FObject,Addr,FrameCount,Frames);
+  //longjmp(_ExceptAddrStack^.Buf^,FPC_Exception);
+  fpc_wasm32_throw_fpcexception;
+end;
+{$endif FPC_SYSTEM_HAS_RAISEEXCEPTION}
+
+
+function fpc_PopObjectStack : TObject;[Public, Alias : 'FPC_POPOBJECTSTACK']; compilerproc;
+var
+  hp : PExceptObject;
+begin
+{$ifdef excdebug}
+  writeln ('In PopObjectstack');
+{$endif}
+  hp:=ExceptObjectStack;
+  if hp=nil then
+    begin
+{$ifdef excdebug}
+      writeln ('At end of ExceptionObjectStack');
+{$endif}
+      halt (1);
+    end
+  else
+    begin
+       { we need to return the exception object to dispose it }
+       if hp^.refcount = 0 then
+         fpc_PopObjectStack:=hp^.FObject
+       else
+         fpc_PopObjectStack:=nil;
+       ExceptObjectStack:=hp^.next;
+       if assigned(hp^.frames) then
+         freemem(hp^.frames);
+       dispose(hp);
+       erroraddr:=nil;
+    end;
+end;
+
+
+{ this is for popping exception objects when a second exception is risen }
+{ in an except/on                                                        }
+function fpc_PopSecondObjectStack : TObject;[Public, Alias : 'FPC_POPSECONDOBJECTSTACK']; compilerproc;
+var
+  hp,_ExceptObjectStack : PExceptObject;
+begin
+{$ifdef excdebug}
+  writeln ('In PopSecondObjectstack');
+{$endif}
+  _ExceptObjectStack:=ExceptObjectStack;
+  If not(assigned(_ExceptObjectStack)) or
+     not(assigned(_ExceptObjectStack^.next)) then
+    begin
+{$ifdef excdebug}
+      writeln ('At end of ExceptionObjectStack');
+{$endif}
+      halt (1);
+    end
+  else
+    begin
+      if _ExceptObjectStack^.next^.refcount=0 then
+        { we need to return the exception object to dispose it if refcount=0 }
+        fpc_PopSecondObjectStack:=_ExceptObjectStack^.next^.FObject
+      else
+        fpc_PopSecondObjectStack:=nil;
+      hp:=_ExceptObjectStack^.next;
+      _ExceptObjectStack^.next:=hp^.next;
+      if assigned(hp^.frames) then
+        freemem(hp^.frames);
+      dispose(hp);
+    end;
+end;
+
+{$ifndef FPC_SYSTEM_HAS_RERAISE}
+Procedure fpc_ReRaise;[Public, Alias : 'FPC_RERAISE']; compilerproc;
+var
+  _ExceptAddrStack : PExceptAddr;
+begin
+{$ifdef excdebug}
+  writeln ('In reraise');
+{$endif}
+//  _ExceptAddrStack:=ExceptAddrStack;
+//  If _ExceptAddrStack=Nil then
+//    DoUnHandledException;
+  ExceptObjectStack^.refcount := 0;
+//  longjmp(_ExceptAddrStack^.Buf^,FPC_Exception);
+  fpc_wasm32_throw_fpcexception;
+end;
+{$endif FPC_SYSTEM_HAS_RERAISE}
+
+function Internal_PopSecondObjectStack : TObject; external name 'FPC_POPSECONDOBJECTSTACK';
+function Internal_PopObjectStack: TObject; external name 'FPC_POPOBJECTSTACK';
+procedure Internal_Reraise; external name 'FPC_RERAISE';
+
+Procedure fpc_ReRaise2;[Public, Alias : 'FPC_RERAISE2']; compilerproc;
+var
+  Newobj : PExceptObject;
+  _ExceptObjectStack : PExceptObject;
+begin
+{$ifdef excdebug}
+  writeln ('In reraise2');
+{$endif}
+  _ExceptObjectStack:=ExceptObjectStack;
+  NewObj:=AllocMem(sizeof(TExceptObject));
+  NewObj^.Next:=_ExceptObjectStack^.Next;
+  _ExceptObjectStack^.Next:=NewObj;
+
+  Internal_Reraise;
+end;
+
+Function fpc_Catches(Objtype : TClass) : TObject;[Public, Alias : 'FPC_CATCHES']; compilerproc;
+var
+  _ExceptObjectStack : PExceptObject;
+begin
+  _ExceptObjectStack:=ExceptObjectStack;
+  If _ExceptObjectStack=Nil then
+   begin
+{$ifdef excdebug}
+     Writeln ('Internal error.');
+{$endif}
+     halt (255);
+   end;
+  if Not ((Objtype = TClass(CatchAllExceptions)) or
+         (_ExceptObjectStack^.FObject is ObjType)) then
+    fpc_Catches:=Nil
+  else
+    begin
+      // catch !
+      fpc_Catches:=_ExceptObjectStack^.FObject;
+      { this can't be done, because there could be a reraise (PFV)
+       PopObjectStack;
+
+       Also the PopAddrStack shouldn't be done, we do it now
+       immediatly in the exception handler (FK)
+      PopAddrStack; }
+    end;
+end;
+
+Procedure SysInitExceptions;
+{
+  Initialize exceptionsupport
+}
+begin
+  ExceptObjectstack:=Nil;
+end;
+
+
+{$ifndef FPC_SYSTEM_HAS_DONEEXCEPTION}
+procedure fpc_doneexception;[public,alias:'FPC_DONEEXCEPTION'] compilerproc;
+begin
+{$ifdef excdebug}
+  Writeln('In doneexception');
+{$endif}
+  Internal_PopObjectStack.Free;
+end;
+{$endif FPC_SYSTEM_HAS_DONEEXCEPTION}
+
+{$ifndef FPC_SYSTEM_HAS_RAISENESTED}
+procedure fpc_raise_nested;[public,alias:'FPC_RAISE_NESTED']compilerproc;
+begin
+{$ifdef excdebug}
+  Writeln('In raise_nested');
+{$endif}
+  Internal_PopSecondObjectStack.Free;
+  Internal_Reraise;
+end;
+{$endif FPC_SYSTEM_HAS_RAISENESTED}
+
+{$ifndef FPC_SYSTEM_HAS_SAFECALLHANDLER}
+function fpc_safecallhandler(obj: TObject): HResult; [public,alias:'FPC_SAFECALLHANDLER']; compilerproc;
+var
+  raiselist: PExceptObject;
+  adr: CodePointer;
+  exc: TObject;
+begin
+  raiselist:=ExceptObjectStack;
+  if Assigned(raiseList) then
+    adr:=raiseList^.Addr
+  else
+    adr:=nil;
+  exc:=Internal_PopObjectStack;
+  if Assigned(obj) and Assigned(exc) then
+    result:=obj.SafeCallException(exc,adr)
+  else
+    result:=E_UNEXPECTED;
+  exc.Free;
+end;
+{$endif FPC_SYSTEM_HAS_SAFECALLHANDLER}

rtl/wasm32/makefile.cpu

@@ -2,5 +2,5 @@
 # Here we set processor dependent include file names.
 #
 
-CPUNAMES=except_native except_branchful
+CPUNAMES=except_exnref except_native except_branchful
 CPUINCNAMES=$(addsuffix .inc,$(CPUNAMES))