Copyright (C) 1994, Digital Equipment Corp.
UNSAFE MODULE RTException EXPORTS RTException, RTExRep;
IMPORT RT0, RTMisc, RTIO, RTParams, RTOS;
IMPORT Thread, ThreadF, M3toC, Ctypes, Csetjmp;
VAR
DEBUG := FALSE;
dump_enabled := FALSE;
TYPE
FinallyProc = PROCEDURE () RAISES ANY;
EXCEPTION
OUCH; (* to keep the compiler from complaining *)
PROCEDURE Raise (en: ExceptionName; arg: ExceptionArg) RAISES ANY =
VAR
f := LOOPHOLE(ThreadF.GetCurrentHandlers(), Frame);
ex: ExceptionList;
BEGIN
IF DEBUG THEN
RTIO.PutText ("---> RAISE:");
RTIO.PutText (" en="); RTIO.PutAddr (en);
RTIO.PutText (" "); RTIO.PutString (en^);
RTIO.PutText (" arg="); RTIO.PutAddr (arg);
RTIO.PutText ("\n");
DumpStack ();
END;
LOOP
IF (f = NIL) THEN NoHandler (en, raises := FALSE); END;
CASE f.class OF
| ORD (ScopeKind.Except) =>
ex := LOOPHOLE (f, PF1).handles;
WHILE (ex^ # NIL) DO
IF (ex^ = en) THEN ResumeRaise (en, arg) END;
INC (ex, ADRSIZE (ex^));
END;
| ORD (ScopeKind.ExceptElse) =>
(* 's' is a TRY-EXCEPT-ELSE frame => go for it *)
ResumeRaise (en, arg);
| ORD (ScopeKind.Finally),
ORD (ScopeKind.FinallyProc),
ORD (ScopeKind.Lock) =>
(* ignore for this pass *)
| ORD (ScopeKind.Raises) =>
(* check that this procedure does indeed raise 'en' *)
ex := LOOPHOLE (f, PF3).raises;
IF ex = NIL THEN NoHandler (en); END;
LOOP
IF (ex^ = NIL) THEN NoHandler (en) END;
IF (ex^ = en) THEN (* ok, it passes *) EXIT END;
INC (ex, ADRSIZE (ex^));
END;
| ORD (ScopeKind.RaisesNone) =>
NoHandler (en);
ELSE
BadStack ();
END;
f := f.next; (* try the previous frame *)
END;
END Raise;
PROCEDURE ResumeRaise (en: ExceptionName; arg: ExceptionArg) RAISES ANY =
VAR
f := LOOPHOLE(ThreadF.GetCurrentHandlers(), Frame);
ex: ExceptionList;
BEGIN
IF DEBUG THEN
RTIO.PutText ("---> RERAISE:");
RTIO.PutText (" en="); RTIO.PutAddr (en);
RTIO.PutText (" "); RTIO.PutString (en^);
RTIO.PutText (" arg="); RTIO.PutAddr (arg);
RTIO.PutText ("\n");
DumpStack ();
END;
LOOP
IF (f = NIL) THEN BadStack (); END;
CASE f.class OF
| ORD (ScopeKind.ExceptElse),
ORD (ScopeKind.Finally) =>
InvokeHandler (f, en, arg);
| ORD (ScopeKind.Except) =>
ex := LOOPHOLE (f, PF1).handles;
WHILE (ex^ # NIL) DO
IF (ex^ = en) THEN InvokeHandler (f, en, arg) END;
INC (ex, ADRSIZE (ex^));
END;
| ORD (ScopeKind.FinallyProc) =>
InvokeFinallyHandler (f, en, arg);
| ORD (ScopeKind.Lock) =>
ReleaseLock (f);
| ORD (ScopeKind.Raises) =>
(* already checked during the first pass *)
ELSE
BadStack ();
END;
ThreadF.SetCurrentHandlers (f.next); (* cut to the new handler *)
f := f.next; (* try the previous frame *)
END;
END ResumeRaise;
PROCEDURE InvokeHandler (f: Frame; en: ExceptionName;
arg: ExceptionArg) RAISES ANY =
VAR p := LOOPHOLE (f, PF1);
BEGIN
IF DEBUG THEN
RTIO.PutText ("--> INVOKE HANDLER:");
RTIO.PutText (" en="); RTIO.PutAddr (en);
RTIO.PutText (" "); RTIO.PutString (en^);
RTIO.PutText (" arg="); RTIO.PutAddr (arg);
RTIO.PutText (" frame="); RTIO.PutAddr (f);
RTIO.PutText (" class="); RTIO.PutInt (f.class);
RTIO.PutText ("\n");
RTIO.Flush ();
END;
ThreadF.SetCurrentHandlers (f.next); (* cut to the new handler *)
p.exception := en; (* record the exception *)
p.arg := arg; (* and it argument *)
Csetjmp.ulongjmp (p.jmpbuf, 1); (* and jump... *)
RAISE OUCH;
END InvokeHandler;
PROCEDURE InvokeFinallyHandler (f: Frame; en: ExceptionName;
arg: ExceptionArg) RAISES ANY =
VAR
p := LOOPHOLE (f, PF2);
cl: RT0.ProcedureClosure;
BEGIN
IF DEBUG THEN
RTIO.PutText ("--> INVOKE FINALLY HANDLER:");
RTIO.PutText (" en="); RTIO.PutAddr (en);
RTIO.PutText (" "); RTIO.PutString (en^);
RTIO.PutText (" arg="); RTIO.PutAddr (arg);
RTIO.PutText (" frame="); RTIO.PutAddr (f);
RTIO.PutText (" class="); RTIO.PutInt (f.class);
RTIO.PutText ("\n");
RTIO.Flush ();
END;
(* build a nested procedure closure *)
cl.marker := RT0.ClosureMarker;
cl.proc := p.handler;
cl.frame := p.frame;
ThreadF.SetCurrentHandlers (f.next); (* cut to the new handler *)
CallProc (LOOPHOLE (ADR (cl), FinallyProc));
END InvokeFinallyHandler;
PROCEDURE CallProc (p: FinallyProc) RAISES ANY =
(* we need to fool the compiler into generating a call
to a nested procedure... *)
BEGIN
p ();
END CallProc;
PROCEDURE ReleaseLock (f: Frame) =
VAR p := LOOPHOLE (f, PF4);
BEGIN
IF DEBUG THEN
RTIO.PutText ("--> UNLOCK:");
RTIO.PutText (" frame="); RTIO.PutAddr (p);
RTIO.PutText (" mutex="); RTIO.PutAddr (LOOPHOLE (p.mutex, ADDRESS));
RTIO.PutText ("\n");
RTIO.Flush ();
END;
ThreadF.SetCurrentHandlers (f.next); (* cut to the new handler *)
Thread.Release (p.mutex); (* and release the lock *)
END ReleaseLock;
PROCEDURE NoHandler (en: ExceptionName; raises := TRUE) =
VAR nm := EName (en);
BEGIN
IF (raises) THEN
RTMisc.FatalError (NIL, 0, "Exception \"", nm, "\" not in RAISES list");
ELSE
RTMisc.FatalError (NIL, 0, "Unhandled exception \"", nm, "\"");
END;
END NoHandler;
PROCEDURE BadStack () =
BEGIN
RTMisc.FatalError (NIL, 0, "corrupt exception stack");
END BadStack;
----------------------------------------------------------- diagnostics ---
PROCEDURE SanityCheck () =
CONST Min_SK = ORD (FIRST (ScopeKind));
CONST Max_SK = ORD (LAST (ScopeKind));
VAR f := LOOPHOLE(ThreadF.GetCurrentHandlers(), Frame);
VAR i: INTEGER;
BEGIN
WHILE (f # NIL) DO
i := f.class;
IF (i < Min_SK) OR (Max_SK < i) THEN BadStack () END;
f := f.next;
END;
END SanityCheck;
PROCEDURE DumpStack () =
VAR f := LOOPHOLE(ThreadF.GetCurrentHandlers(), Frame);
BEGIN
IF NOT DEBUG AND NOT dump_enabled THEN RETURN; END;
RTOS.LockHeap (); (* disable thread switching... (you wish!) *)
RTIO.PutText ("------------------ EXCEPTION HANDLER STACK ---------------------\n");
WHILE (f # NIL) DO
RTIO.PutAddr (f);
CASE f.class OF
| ORD (ScopeKind.Except) =>
RTIO.PutText (" TRY-EXCEPT ");
DumpHandles (LOOPHOLE (f, PF1).handles);
| ORD (ScopeKind.ExceptElse) =>
RTIO.PutText (" TRY-EXCEPT-ELSE ");
| ORD (ScopeKind.Finally) =>
RTIO.PutText (" TRY-FINALLY ");
| ORD (ScopeKind.FinallyProc) =>
VAR x := LOOPHOLE (f, PF2); BEGIN
RTIO.PutText (" TRY-FINALLY proc = ");
RTIO.PutAddr (x.handler);
RTIO.PutText (" frame = ");
RTIO.PutAddr (x.frame);
END;
| ORD (ScopeKind.Raises) =>
RTIO.PutText (" RAISES ");
DumpHandles (LOOPHOLE (f, PF3).raises);
| ORD (ScopeKind.RaisesNone) =>
RTIO.PutText (" RAISES {}");
| ORD (ScopeKind.Lock) =>
VAR x := LOOPHOLE (f, PF4); BEGIN
RTIO.PutText (" LOCK mutex = ");
RTIO.PutAddr (LOOPHOLE (x.mutex, ADDRESS));
END;
ELSE
RTIO.PutText (" *** BAD EXCEPTION RECORD, class = ");
RTIO.PutInt (f.class);
RTIO.PutText (" ***\n");
EXIT;
END;
RTIO.PutText ("\n");
f := f.next;
END;
RTIO.PutText ("----------------------------------------------------------------\n");
RTIO.Flush ();
RTOS.UnlockHeap ();
END DumpStack;
PROCEDURE DumpHandles (x: ExceptionList) =
VAR first := TRUE; en: ExceptionName;
BEGIN
RTIO.PutText (" {");
IF (x # NIL) THEN
WHILE (x^ # NIL) DO
IF (NOT first) THEN RTIO.PutText (", "); END;
first := FALSE;
en := x^;
RTIO.PutString (en^);
INC (x, ADRSIZE (x^));
END;
END;
RTIO.PutText ("}");
END DumpHandles;
PROCEDURE EName (en: ExceptionName): TEXT =
BEGIN
RETURN M3toC.StoT (LOOPHOLE (en^, Ctypes.char_star));
END EName;
BEGIN
dump_enabled := RTParams.IsPresent ("stackdump");
EVAL SanityCheck; (* avoid the unused warning *)
END RTException.