(* ETH Oberon, Copyright 2000 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich.
Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)

MODULE Traps;  

(* 2000.02.06	g.f.	release 2.3.6d	*)
(* 2000.03.30	g.f.	more rubust trap handling while loading system *)
(* 2001.01.06	g.f.	adapted to new compiler *)
(* 2001.02.19	g.f.	Exception Handling added *)
(* 2002.01.03	g.f.	signal 13 no longer exits Oberon  *)
(* 2006.07.09	g.f.	Unix-Aos version	*)

IMPORT S := SYSTEM, Trace, Glue, Unix, Objects, Machine, Heaps, Streams, Modules, Reflection, KernelLog;  


TYPE 	
	Address = S.ADDRESS;
	
	WriterFactory = PROCEDURE (): Streams.Writer;
	
	TrapWriter = OBJECT (Streams.StringWriter)
	(* pooling trap writer, EXCLUSIVE sections and allocation forbidden within trap! *)
	VAR
		trapped: BOOLEAN;
		factory: WriterFactory;

		PROCEDURE Trapped;
		BEGIN trapped := TRUE;
		END Trapped;

		PROCEDURE &InitTrapWriter*;
		BEGIN InitStringWriter (Streams.DefaultWriterSize); trapped := FALSE
		END InitTrapWriter;

		PROCEDURE SetFactory (factory: WriterFactory);
		BEGIN SELF.factory := factory;
		END SetFactory;

		PROCEDURE Write;
		VAR contents: ARRAY Streams.DefaultWriterSize OF CHAR; 
			len: LONGINT; writer: Streams.Writer;
		BEGIN 
			GetRaw (contents, len); 
			Reset; writer := factory (); writer.Bytes (contents, 0, len); 
			writer.Update;
		END Write;

	BEGIN {ACTIVE}
		LOOP
			 Objects.Sleep(100);
			 IF trapped THEN Write; trapped := FALSE
			 ELSIF factory = NIL THEN RETURN
			 END;
		END;
	END TrapWriter;
		
	
	
	TrapWriter2 = OBJECT (TrapWriter)
		
		PROCEDURE Char( c: CHAR);
		BEGIN  Trace.Char( c )  END Char;
		
		PROCEDURE String( CONST s: ARRAY OF CHAR);
		BEGIN  Trace.String( s )  END String;

		PROCEDURE Ln;
		BEGIN  Trace.Ln  END Ln;
	
		
		PROCEDURE Update;
		END Update;
		
		PROCEDURE Trapped;
		END Trapped;
		
	END TrapWriter2;
	
	SigHandler = PROCEDURE ( sig: LONGINT; scp, ucp, dum: Address );  
	
VAR 
	InstallSignalHandler: PROCEDURE ( h: SigHandler );  
	
	TrapHandlingLevel: INTEGER;  
	hexDigit: ARRAY 17 OF CHAR;
	
	debug: SET;  
	
	trapWriter: TrapWriter;
	defaultWriter: Streams.Writer;
	
	w2: TrapWriter2;
	
	
	PROCEDURE Append( VAR ar: ARRAY OF CHAR;  CONST this: ARRAY OF CHAR );
	VAR i, j: LONGINT;
	BEGIN
		i := 0;  j := 0;
		WHILE ar[i] # 0X DO  INC( i )  END;
		WHILE (i < LEN( ar ) - 1) & (this[j] # 0X) DO  ar[i] := this[j];  INC( i );  INC( j )  END;
		ar[i] := 0X
	END Append;
	
	
	PROCEDURE GetTypeName( tag: Address;  VAR name: ARRAY OF CHAR );
	VAR  typ: Modules.TypeDesc;
	BEGIN
		S.GET( tag - 4, typ );  name[0] := 0X;
		IF typ.mod # NIL THEN  Append( name, typ.mod.name );  Append( name,  "." )  END;
		Append( name, typ.name )
	END GetTypeName;

	PROCEDURE Trap( sig: LONGINT;  ucp: Unix.Ucontext );  
	VAR 
		pc, sp, bp: Address;  
		trapno: LONGINT;  
		trthr: Objects.Process;  handled: BOOLEAN;  
		w: Streams.Writer;
	
	PROCEDURE FinishTrapText( exitAos: BOOLEAN );
		VAR tag: Address;  name: ARRAY 72 OF CHAR;
		BEGIN
			
			w.Ln; w.Ln; 
			w.String("----------------------------------------------------"); w.Ln; 
			w.Char( 2X );   (* end of trap text *) 
			w.Update;
			IF trapWriter # NIL THEN  trapWriter.Trapped;  trapWriter.Update  END;
			
			IF exitAos THEN  Unix.exit( 1 )  END;
			
			S.GET( S.VAL( Address, trthr.obj ) - 4, tag );
			GetTypeName( tag, name );
			IF name = "Oberon.System.OberonRunner" THEN  UnlockOberon  END;
			TrapHandlingLevel := 0;
			Machine.Release( Machine.Trap );
		END FinishTrapText;
		
	BEGIN 
		INC( TrapHandlingLevel ); 
		IF 3 IN debug THEN  
			Trace.String( "Aos Trap:  signal = " );  Trace.Int( sig, 0 );  
			Trace.String( ",  ucp = " );  Trace.Hex( S.VAL( Address, ucp ), -8 );  
			Trace.String( ", traphandling  level = " ); Trace.Int( TrapHandlingLevel, 1 );  
			Trace.Ln;  
		END;  
		
		trthr := Objects.CurrentProcess( );  
		IF Heaps.collecting THEN  trapWriter := w2  END;
		IF trapWriter = NIL THEN  w := defaultWriter  ELSE  w := trapWriter  END;
			
		w.Char( 1X );   (* begin of trap text *) 
		w.Ln;  
		w.String( Machine.version ); w.Ln; w.Ln;
		IF TrapHandlingLevel = 1 THEN  
			Machine.Acquire( Machine.Trap );
			w.String( "Trap " ) 
		ELSE  
			w.String( "==== recursive Trap" )  
		END;  
		CASE sig OF 
		| 1:       w.String( "  1 (Hangup signal)" );   
		| 2:       w.String( "  2 (User interrupt)" );   
		| 3:       w.String( "  3 (Quit signal)" );   
		| 4:       w.String( "  4 (Illegal instruction)" );   
		| 5:       w.String( "  5." );  
				sp := ucp.mc.espatsig;
				S.GET( sp, trapno );  w.Int( trapno, 0 );  
				CASE trapno OF 
				| 1:       w.String( "  (WITH guard failed)" ) 
				| 2:       w.String( "  (CASE invalid)" ) 
				| 3:       w.String( "  (RETURN missing)" ) 
				| 5:       w.String( "  (Implicit type guard failed)" ) 
				| 6:       w.String( "  (Type guard failed)" ) 
				| 7:       w.String( "  (Index out of range)" ) 
				| 8:       w.String( "  (ASSERT failed)" ) 
				| 9:       w.String( "  (Array dimension error)" ) 
				ELSE 
					IF trapno >= 30 THEN  w.String( "  (programmed HALT)" )  
					ELSE  w.String( "  (unknown trap, division error?)" )   
					END  
				END;   
		| 8:       w.String( "  8 (Arithmetic exception)" );   
		| 10:     w.String( "  10 (Bus Error)" ) 
		| 11:     w.String( "  11 (Segmentation violation)" ) 
		| 13:     w.String( "  13 (Broken pipe)" ) 
		| 14:     w.String( "  14 (Alarm signal)" ) 
		ELSE 
			w.String( "  (Signal " );  w.Int( sig, 0 );  w.String( ") " );  
		END;  
		w.Ln;  
		IF TrapHandlingLevel > 1 THEN 
			FinishTrapText( Heaps.collecting OR (TrapHandlingLevel > 2) );
			Objects.Terminate
		ELSE
			pc := ucp.mc.eip;  bp := ucp.mc.ebp;
			IF pc = 0 THEN  
				(* assume call of procedure variable with value NIL *)
				S.GET( sp, pc );   (* get return address on top of stack *)
			END;  	
			w.String( "SP = " );  w.Address( sp );  w.Char( 'H' );
			w.String( ", FP = " );  w.Address( bp );  w.Char( 'H' );
			w.String( ", PC = " );  w.Address( pc );  w.Char( 'H' );  w.Ln;  
			w.Ln;  
			HandleException( w, trthr, bp, sp, pc, handled ); 
			IF ~handled THEN  (* stack dump *)
				Reflection.StackTraceBack( w, pc, bp, TRUE, FALSE )
			END;  
			FinishTrapText( FALSE );
			IF Heaps.collecting THEN  Machine.Shutdown( FALSE );  Objects.Terminate  END;  
			IF 3 IN debug THEN  
				Trace.String( "Teminating trapped thread " );  Trace.Int( trthr.id , 0 ); Trace.Ln
			END;  
			Objects.ExitTrap() 
		END
	END Trap;  
	
	
	PROCEDURE UnlockOberon;
	CONST OberonKernel = "Oberon.Kernel";
	VAR c: PROCEDURE;
	BEGIN
		IF Modules.ModuleByName (OberonKernel) # NIL THEN
			GETPROCEDURE (OberonKernel, "UnlockOberon", c);
			IF c # NIL THEN c END
		END;
	END UnlockOberon;
	

	(* Handles an exception. Interrupts are on during this procedure. *)
	PROCEDURE HandleException( w: Streams.Writer; obj: Objects.Process; fp, sp, pc: Address;  VAR handled: BOOLEAN );  
	VAR handler: Address;  
	BEGIN 
		handler := Modules.GetExceptionHandler( pc );   
		IF handler # -1 THEN  (* Handler in the current PAF *)
			(*
			int.EIP := handler;  
			SetTrapVariable( pc, fp );  SetLastExceptionState( exc );
			*)
			handled := TRUE;  
		ELSE  
			WHILE Machine.LessOrEqual( fp, obj.stackBottom) & (handler = -1) DO  
				S.GET( fp + 4, pc );  
				pc := pc - 1;   (*  CALL instruction, machine dependant!!! *)
				handler := Modules.GetExceptionHandler( pc );  
				sp := fp;   (* Save the old framepointer into the stack pointer *)
				S.GET( fp, fp ) (* Unwind PAF *)
			END;  
			IF handler = -1 THEN  handled := FALSE   
			ELSE 
				(*
				int.EIP := handler;  int.EBP := fp;  int.ESP := sp;  
				SetTrapVariable( pc, fp );  SetLastExceptionState( exc );  
				*)
				handled := TRUE  
			END  
		END;  
		IF handled THEN  
			w.String( "(exception handler found but exception handling not yet implemented)" );  
			w.Ln;  w.Ln;  
			handled := FALSE   
		END  
	END HandleException;  
	
	PROCEDURE InstallTrapWriterFactory*( factory: WriterFactory );
	BEGIN
		IF factory = NIL THEN
			trapWriter.SetFactory (NIL);
			trapWriter := NIL
		ELSE
			IF trapWriter = NIL THEN NEW (trapWriter) END;
			trapWriter.SetFactory (factory)
		END
	END InstallTrapWriterFactory;
	
	
	PROCEDURE SignalHandler( signal: LONGINT;  scp, ucp, dum: Address );   
		(* 'dum' for 16 byte stack alignment, MacOS! *)
	CONST SIGALRM = 14;  
	VAR ures, i: LONGINT;
	BEGIN 
		IF 3 IN debug THEN  
			Trace.String( "Traps.SignalHander: received signal " );  
			Trace.Int( signal, 1 );  Trace.Ln  
		END;  
		IF signal IN  {1, 2, 15} (* SIGHUP. SIGINT, SIGTERM *) THEN  
			FOR i := 0 TO Machine.MaxLocks -1 DO
				Trace.Char( Machine.lock[i] )
			END;
			Trace.Ln;
			RETURN   
		END;  
		IF Heaps.collecting THEN  
			IF signal = SIGALRM THEN  
				(* delay delivery *)  ures := Unix.alarm( 1 );  RETURN  
			ELSE  
				Trace.Ln;  Trace.String( "PANIC: Trap " );  Trace.Int( signal, 0 );  
				Trace.String( " in garbage collector" );  Trace.Ln;  
				Machine.Release( Machine.Heaps );
				Machine.Release( Machine.X11 );
				Trap( signal, S.VAL( Unix.Ucontext, ucp ) )  
			END;  
		ELSE  
			Trap( signal, S.VAL( Unix.Ucontext, ucp ) )  
		END  
	END SignalHandler;  
	


BEGIN 
	debug := Glue.debug;  hexDigit := "0123456789ABCDEF";
	Unix.Dlsym( 0, "InstallTrap", S.VAL( Address, InstallSignalHandler ) );
	InstallSignalHandler( SignalHandler );
	Streams.OpenWriter( defaultWriter, KernelLog.Send ); trapWriter := NIL;
	NEW( w2 );
END Traps.