Copyright (C) 1994, Digital Equipment Corp.
UNSAFE MODULE RTException EXPORTS RTException, RTExRep;
IMPORT RT0, RTMisc, RTProcedureSRC, RTIO, RTModule, RTOS, RTStack;
IMPORT Thread, M3toC, Cstring, Ctypes, RTProcedure, RTParams;
VAR
DEBUG := FALSE;
dump_enabled := FALSE;
EXCEPTION
OUCH; (* to keep the compiler from complaining *)
PROCEDURE Raise (en: ExceptionName; arg: ExceptionArg) RAISES ANY =
VAR
here, f: RTStack.Frame;
s: Scope;
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;
RTStack.CurrentFrame (here);
RTStack.PreviousFrame (here, f); (* skip self *)
LOOP
IF (f.pc = NIL) THEN
(* we're at the end of the stack (or we got lost along the way!) *)
NoHandler (en, raises := FALSE);
END;
s := FindScope (f.pc);
IF (s # NIL) THEN
LOOP
IF (s.start <= f.pc) AND (f.pc <= s.stop) THEN
CASE ORD (s.kind) OF
| ORD (ScopeKind.Except) =>
ex := s.excepts;
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.RaisesNone) =>
NoHandler (en);
| ORD (ScopeKind.Raises) =>
(* check that this procedure does indeed raise 'en' *)
ex := s.excepts;
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;
ELSE <*ASSERT FALSE*>
END;
IF (s.outermost # '\000') THEN EXIT END;
END;
IF (s.end_of_list # '\000') THEN EXIT END;
(* try the next scope in the list *)
INC (s, ADRSIZE (s^));
END;
END;
(* try the previous frame *)
RTStack.PreviousFrame (f, f);
END;
END Raise;
PROCEDURE ResumeRaise (en: ExceptionName; arg: ExceptionArg) RAISES ANY =
VAR
here, f: RTStack.Frame;
s: Scope;
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;
RTStack.CurrentFrame (here);
RTStack.PreviousFrame (here, f); (* skip self *)
LOOP
IF (f.pc = NIL) THEN
(* we're at the end of the stack (or we got lost along the way!) *)
NoHandler (en, raises := FALSE);
END;
s := FindScope (f.pc);
IF (s # NIL) THEN
LOOP
IF (s.start <= f.pc) AND (f.pc <= s.stop) THEN
CASE ORD (s.kind) OF
| ORD (ScopeKind.Except) =>
ex := s.excepts;
WHILE (ex^ # NIL) DO
IF (ex^ = en) THEN InvokeHandler (s, f, en, arg) END;
INC (ex, ADRSIZE (ex^));
END;
MarkHandler (s, f, en, arg);
(* we need to mark every frame so that no matter where
we unwind to, it sees a marked frame => exception *)
| ORD (ScopeKind.ExceptElse) =>
(* 's' is a TRY-EXCEPT-ELSE frame => go for it *)
InvokeHandler (s, f, en, arg);
| ORD (ScopeKind.Finally),
ORD (ScopeKind.FinallyProc) =>
InvokeHandler (s, f, en, arg);
| ORD (ScopeKind.Lock) =>
ReleaseLock (s, f);
| ORD (ScopeKind.Raises) =>
(* already checked during the first pass *)
ELSE <*ASSERT FALSE *>
END;
IF (s.outermost # '\000') THEN EXIT END;
END;
IF (s.end_of_list # '\000') THEN EXIT END;
(* try the next scope in the list *)
INC (s, ADRSIZE (s^));
END;
END;
(* try the previous frame *)
RTStack.PreviousFrame (f, f);
END;
END ResumeRaise;
PROCEDURE InvokeHandler (s: Scope; READONLY f: RTStack.Frame;
en: ExceptionName; arg: ExceptionArg) RAISES ANY =
VAR p : UNTRACED REF ExceptionInfo := f.sp + s.offset;
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 (" pc="); RTIO.PutAddr (f.pc);
RTIO.PutText (" sp="); RTIO.PutAddr (f.sp);
RTIO.PutText (" info="); RTIO.PutAddr (p);
RTIO.PutText ("\n");
RTIO.Flush ();
END;
p.exception := en;
p.arg := arg;
RTStack.Unwind (f);
RTMisc.FatalErrorPC (LOOPHOLE (f.pc, INTEGER), "Unwind returned!");
RAISE OUCH;
END InvokeHandler;
PROCEDURE MarkHandler (s: Scope; READONLY f: RTStack.Frame;
en: ExceptionName; arg: ExceptionArg) =
VAR p : UNTRACED REF ExceptionInfo := f.sp + s.offset;
BEGIN
IF DEBUG THEN
RTIO.PutText ("--> MARK HANDLER:");
RTIO.PutText (" en="); RTIO.PutAddr (en);
RTIO.PutText (" "); RTIO.PutString (en^);
RTIO.PutText (" arg="); RTIO.PutAddr (arg);
RTIO.PutText (" pc="); RTIO.PutAddr (f.pc);
RTIO.PutText (" sp="); RTIO.PutAddr (f.sp);
RTIO.PutText (" info="); RTIO.PutAddr (p);
RTIO.PutText ("\n");
RTIO.Flush ();
END;
p.exception := en;
p.arg := arg;
END MarkHandler;
PROCEDURE ReleaseLock (s: Scope; READONLY f: RTStack.Frame) =
VAR p : UNTRACED REF MUTEX := f.sp + s.offset;
BEGIN
IF DEBUG THEN
RTIO.PutText ("--> UNLOCK:");
RTIO.PutText (" pc="); RTIO.PutAddr (f.pc);
RTIO.PutText (" sp="); RTIO.PutAddr (f.sp);
RTIO.PutText (" info="); RTIO.PutAddr (p);
RTIO.PutText (" mutex="); RTIO.PutAddr (LOOPHOLE (p^, ADDRESS));
RTIO.PutText ("\n");
RTIO.Flush ();
END;
<*ASSERT p^ # NIL *>
Thread.Release (p^);
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;
------------------------------------------------------- scope searching ---
Note: we assume that the text of a single compilation unit is contiguous
(i.e. the linker doesn't split and shuffle compilation units in little
pieces).
TYPE
PCMap = UNTRACED REF ARRAY OF MapEntry;
MapEntry = RECORD
base : ADDRESS;
module : RT0.ModulePtr;
END;
VAR pc_map: PCMap := NIL;
PROCEDURE FindScope (pc: ADDRESS): Scope =
VAR
base: ADDRESS;
lo, hi, mid, limit: CARDINAL;
p: UNTRACED REF MapEntry;
s: Scope;
BEGIN
IF (pc_map = NIL) THEN
RTOS.LockHeap ();
BuildPCMap ();
RTOS.UnlockHeap ();
END;
(* binary search of the sorted table *)
limit:= NUMBER (pc_map^);
base := ADR (pc_map[0]);
lo := 0;
hi := limit;
WHILE (lo < hi) DO
mid := (lo + hi) DIV 2;
p := base + mid * ADRSIZE (p^);
IF (pc < p.base)
THEN hi := mid;
ELSE lo := mid + 1;
END;
END;
IF (lo > 0) THEN DEC (lo) END;
(* linear search of the modules that might contain pc *)
LOOP
IF (lo >= limit) THEN RETURN NIL END;
p := base + lo * ADRSIZE (p^);
IF (p.base > pc) THEN RETURN NIL END;
IF FindScopeInModule (pc, p.module.try_scopes, s) THEN RETURN s END;
INC (lo);
END;
END FindScope;
PROCEDURE FindScopeInModule (pc: ADDRESS; s: Scope; VAR x: Scope): BOOLEAN =
VAR above, below: BOOLEAN := FALSE;
BEGIN
x := NIL;
IF (s = NIL) THEN RETURN FALSE END;
LOOP
IF (s.start <= pc) AND (pc <= s.stop) THEN x := s; RETURN TRUE; END;
IF (s.start <= pc) THEN below := TRUE END;
IF (s.stop >= pc) THEN above := TRUE END;
IF (s.end_of_list # '\000') THEN RETURN (above AND below) END;
INC (s, ADRSIZE (s^));
END;
END FindScopeInModule;
----------------------------------------------------- sorted module map ---
PROCEDURE BuildPCMap () =
VAR n: INTEGER; map: PCMap; m: RT0.ModulePtr;
BEGIN
(* first, count the modules with exception scopes *)
n := 0;
FOR i := 0 TO RTModule.Count () - 1 DO
m := RTModule.Get (i);
IF (m # NIL) AND (m.try_scopes # NIL) THEN INC (n); END;
END;
(* allocate space for the map *)
map := NEW (PCMap, n);
(* install the modules with exception scopes into the map *)
n := 0;
FOR i := 0 TO RTModule.Count () - 1 DO
m := RTModule.Get (i);
IF (m # NIL) AND (m.try_scopes # NIL) THEN
map[n].base := MinPC (m);
map[n].module := m;
INC (n);
END;
END;
(* sort the maps *)
QuickSort (map^, 0, n);
InsertionSort (map^, 0, n);
(* and finally, install them *)
pc_map := map;
END BuildPCMap;
PROCEDURE MinPC (m: RT0.ModulePtr): ADDRESS =
VAR
s := LOOPHOLE (m.try_scopes, Scope);
min := s.start;
BEGIN
LOOP
IF (s.start < min) THEN min := s.start; END;
IF (s.end_of_list # '\000') THEN EXIT; END;
INC (s, ADRSIZE (s^));
END;
RETURN min;
END MinPC;
PROCEDURE QuickSort (VAR a: ARRAY OF MapEntry; lo, hi: INTEGER) =
CONST CutOff = 9;
VAR i, j: INTEGER; key, tmp, t_lo, t_hi, t_i: MapEntry;
BEGIN
WHILE (hi - lo > CutOff) DO (* sort a[lo..hi) *)
(* use median-of-3 to select a key *)
i := (hi + lo) DIV 2;
t_lo := a [lo];
t_hi := a [hi-1];
t_i := a [i];
IF (t_lo.base < t_i.base) THEN
IF (t_i.base < t_hi.base) THEN
key := t_i;
ELSIF (t_lo.base < t_hi.base) THEN
key := t_hi;
a[hi-1] := t_i;
a[i] := key;
ELSE
key := t_lo;
a[lo] := t_hi;
a[hi-1] := t_i;
a[i] := key;
END;
ELSE
IF (t_hi.base < t_i.base) THEN
key := t_i;
a[hi-1] := t_lo;
a[lo] := t_hi;
ELSIF (t_lo.base < t_hi.base) THEN
key := t_lo;
a[lo] := t_i;
a[i] := t_lo;
ELSE
key := t_hi;
a[hi-1] := t_lo;
a[lo] := t_i;
a[i] := t_hi;
END;
END;
(* partition the array *)
i := lo+1; j := hi-2;
(* find the first hole *)
WHILE (a [j].base > key.base) DO DEC (j) END;
tmp := a [j];
DEC (j);
LOOP
IF (i > j) THEN EXIT END;
WHILE (a [i].base < key.base) DO INC (i) END;
IF (i > j) THEN EXIT END;
a[j+1] := a [i];
INC (i);
WHILE (a [j].base > key.base) DO DEC (j) END;
IF (i > j) THEN IF (j = i-1) THEN DEC (j) END; EXIT END;
a[i-1] := a [j];
DEC (j);
END;
(* fill in the last hole *)
a[j+1] := tmp;
i := j+2;
(* then, recursively sort the smaller subfile *)
IF (i - lo < hi - i)
THEN QuickSort (a, lo, i-1); lo := i;
ELSE QuickSort (a, i, hi); hi := i-1;
END;
END; (* WHILE (hi-lo > CutOff) *)
END QuickSort;
PROCEDURE InsertionSort (VAR a: ARRAY OF MapEntry; lo, hi: INTEGER) =
VAR j: INTEGER; key: MapEntry;
BEGIN
FOR i := lo+1 TO hi-1 DO
key := a [i];
j := i-1;
WHILE (j >= lo) AND (key.base < a [j].base) DO
a[j+1] := a [j];
DEC (j);
END;
a[j+1] := key;
END;
END InsertionSort;
----------------------------------------------------------- diagnostics ---
VAR NoName := ARRAY [0..15] OF CHAR {'s','t','a','t','i','c',' ',
'p','r','o','c','e','d','u','r','e'};
PROCEDURE DumpStack () =
CONST CallInstructionSize = 4;
VAR
here, f: RTStack.Frame;
s: Scope;
ex: ExceptionList;
name: RTProcedureSRC.Name;
file: RTProcedureSRC.Name;
proc: RTProcedure.Proc;
offset: INTEGER;
info: ADDRESS;
BEGIN
IF NOT DEBUG AND NOT dump_enabled THEN RETURN; END;
RTOS.LockHeap (); (* disable thread switching... (you wish!) *)
RTIO.PutText ("------------------------- STACK DUMP ---------------------------\n");
RTIO.PutText ("----PC---- ----SP---- \n");
RTStack.CurrentFrame (here);
RTStack.PreviousFrame (here, f); (* skip self *)
WHILE (f.pc # NIL) DO
(* print the active scopes *)
s := FindScope (f.pc);
IF (s # NIL) THEN
LOOP
IF (s.start <= f.pc) AND (f.pc <= s.stop) THEN
RTIO.PutText (" [");
RTIO.PutAddr (s.start);
RTIO.PutText ("..");
RTIO.PutAddr (s.stop);
RTIO.PutText ("] ");
info := f.sp + s.offset;
CASE ORD (s.kind) OF
| ORD (ScopeKind.Finally),
ORD (ScopeKind.FinallyProc) =>
RTIO.PutText ("TRY-FINALLY");
DumpInfo (info);
| ORD (ScopeKind.Lock) =>
RTIO.PutText ("LOCK");
DumpInfo (info);
RTIO.PutText (" mutex = ");
RTIO.PutAddr (LOOPHOLE (info, UNTRACED REF ADDRESS)^);
| ORD (ScopeKind.Except) =>
ex := s.excepts;
RTIO.PutText ("TRY-EXCEPT"); DumpHandles (ex);
DumpInfo (info);
| ORD (ScopeKind.ExceptElse) =>
RTIO.PutText ("TRY-EXCEPT-ELSE");
DumpInfo (info);
| ORD (ScopeKind.Raises),
ORD (ScopeKind.RaisesNone) =>
RTIO.PutText ("RAISES");
DumpHandles (s.excepts);
ELSE
(* we found a mysterious scope!? *)
RTIO.PutText ("??? BAD EXCEPTION SCOPE, kind = ");
RTIO.PutInt (ORD (s.kind));
RTIO.PutText (" ???\n");
EXIT;
END;
RTIO.PutText ("\n");
IF (s.outermost # '\000') THEN EXIT END;
END;
IF (s.end_of_list # '\000') THEN EXIT END;
(* try the next scope in the list *)
INC (s, ADRSIZE (s^));
END;
END;
(* print the procedure's frame *)
RTIO.PutAddr (f.pc-CallInstructionSize, 10);
RTIO.PutText (" ");
RTIO.PutAddr (f.sp, 10);
RTProcedureSRC.FromPC (f.pc, proc, file, name);
IF (name # NIL) THEN
offset := f.pc - proc;
IF (0 <= offset) AND (offset < 2048) THEN
RTIO.PutText (" "); RTIO.PutString (name);
IF (offset # 0) THEN RTIO.PutText (" + "); RTIO.PutHex (offset); END;
IF (file # NIL) THEN RTIO.PutText(" in "); RTIO.PutString(file); END;
END;
END;
name := RTStack.ProcName (f);
IF (name # NIL)
AND Cstring.memcmp (name, ADR(NoName), NUMBER(NoName)) # 0 THEN
RTIO.PutText (" ["); RTIO.PutString (name); RTIO.PutText ("]");
END;
RTIO.PutText ("\n");
(* try the previous frame *)
RTStack.PreviousFrame (f, f);
END;
RTIO.PutText ("----------------------------------------------------------------\n");
RTIO.Flush ();
RTOS.UnlockHeap (); (* re-enable thread switching *)
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 DumpInfo (a: ADDRESS) =
BEGIN
IF DEBUG THEN
RTIO.PutText (" info=");
RTIO.PutAddr (a);
END;
END DumpInfo;
PROCEDURE EName (en: ExceptionName): TEXT =
BEGIN
RETURN M3toC.StoT (LOOPHOLE (en^, Ctypes.char_star));
END EName;
BEGIN
dump_enabled := RTParams.IsPresent ("stackdump");
<*ASSERT RTStack.Has_walker*>
END RTException.