Copyright (C) 1994, Digital Equipment Corp.
UNSAFE MODULE------------------------------------------------------- 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).RTException EXPORTSRTException ,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 *) PROCEDURERaise (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; PROCEDUREResumeRaise (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; PROCEDUREInvokeHandler (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; PROCEDUREMarkHandler (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; PROCEDUREReleaseLock (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; PROCEDURENoHandler (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;
TYPE PCMap = UNTRACED REF ARRAY OF MapEntry; MapEntry = RECORD base : ADDRESS; module : RT0.ModulePtr; END; VAR pc_map: PCMap := NIL; PROCEDURE----------------------------------------------------- sorted module map ---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; PROCEDUREFindScopeInModule (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;
PROCEDURE----------------------------------------------------------- diagnostics ---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; PROCEDUREMinPC (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; PROCEDUREQuickSort (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; PROCEDUREInsertionSort (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;
VAR NoName := ARRAY [0..15] OF CHAR {'s','t','a','t','i','c',' ', 'p','r','o','c','e','d','u','r','e'}; PROCEDUREDumpStack () = 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; PROCEDUREDumpHandles (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; PROCEDUREDumpInfo (a: ADDRESS) = BEGIN IF DEBUG THEN RTIO.PutText (" info="); RTIO.PutAddr (a); END; END DumpInfo; PROCEDUREEName (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.