Copyright (C) 1994, Digital Equipment Corp.
File: Marker.m3
MODULE---------------------------------------------------------- marker stack ---; IMPORT CG, Error, Type, Variable, ProcType, ESet, Expr, AssignStmt; IMPORT M3ID, M3RT, Target, Module, Runtime, Procedure; TYPE Kind = { zFINALLY, zFINALLYPROC, zLOCK, zEXIT, zTRY, zTRYELSE, zRAISES, zPROC}; FramePtr = REF Frame; Frame = RECORD kind : Kind; outermost : BOOLEAN; saved : BOOLEAN; returnSeen : BOOLEAN; exitSeen : BOOLEAN; info : CG.Var; start : CG.Label; stop : CG.Label; type : Type.T; (* kind = PROC *) variable : Variable.T; (* kind = PROC *) e_set : ESet.T; (* kind = RAISES, TRY *) next : FramePtr; callConv : CG.CallingConvention; END; CONST RT_Kind = ARRAY Kind OF INTEGER { ORD (M3RT.HandlerClass.Finally), ORD (M3RT.HandlerClass.FinallyProc), ORD (M3RT.HandlerClass.Lock), -1, (* exit *) ORD (M3RT.HandlerClass.Except), ORD (M3RT.HandlerClass.ExceptElse), ORD (M3RT.HandlerClass.Raises), -1 (* proc *) }; VAR all_frames : FramePtr := NIL; n_frames : INTEGER := 0; save_depth : INTEGER := 0; frame_stack : CG.Var := NIL; setjmp : CG.Proc := NIL; tos : INTEGER := 0; stack : ARRAY [0..50] OF Frame; Marker
PROCEDURE--------------------------------------------- explicit frame operations ---SaveFrame () = VAR p := NEW (FramePtr); BEGIN <*ASSERT save_depth >= 0*> WITH z = stack [tos-1] DO z.saved := TRUE; INC (save_depth); p^ := z; (******* p.outermost := (save_depth <= 1); - this only works if the front-end doesn't inline nested procedures and the back-end doesn't screw around reordering labels. ********) p.next := all_frames; all_frames := p; INC (n_frames); END; END SaveFrame; <*INLINE*> PROCEDUREPop () = BEGIN DEC (tos); IF (stack[tos].saved) THEN DEC (save_depth) END; <*ASSERT save_depth >= 0*> END Pop; PROCEDUREPushFinally (l_start, l_stop: CG.Label; info: CG.Var) = BEGIN Push (Kind.zFINALLY, l_start, l_stop, info); END PushFinally; PROCEDUREPushFinallyProc (l_start, l_stop: CG.Label; info: CG.Var) = BEGIN Push (Kind.zFINALLYPROC, l_start, l_stop, info); END PushFinallyProc; PROCEDUREPopFinally (VAR(*OUT*) returnSeen, exitSeen: BOOLEAN) = BEGIN Pop (); returnSeen := stack[tos].returnSeen; exitSeen := stack[tos].exitSeen; END PopFinally; PROCEDUREPushLock (l_start, l_stop: CG.Label; mutex: CG.Var) = BEGIN Push (Kind.zLOCK, l_start, l_stop, mutex); END PushLock; PROCEDUREPushTry (l_start, l_stop: CG.Label; info: CG.Var; ex: ESet.T) = BEGIN Push (Kind.zTRY, l_start, l_stop, info, ex); END PushTry; PROCEDUREPushTryElse (l_start, l_stop: CG.Label; info: CG.Var) = BEGIN Push (Kind.zTRYELSE, l_start, l_stop, info); END PushTryElse; PROCEDUREPushExit (l_stop: CG.Label) = BEGIN Push (Kind.zEXIT, l_stop := l_stop); END PushExit; PROCEDUREPushRaises (l_start, l_stop: CG.Label; ex: ESet.T; info: CG.Var) = BEGIN Push (Kind.zRAISES, l_start, l_stop, info, ex); END PushRaises; PROCEDUREPushProcedure (t: Type.T; v: Variable.T; cc: CG.CallingConvention) = BEGIN <* ASSERT (t = NIL) = (v = NIL) *> Push (Kind.zPROC); WITH z = stack[tos - 1] DO z.type := t; z.variable := v; z.callConv := cc; END; END PushProcedure; PROCEDUREPush (k: Kind; l_start, l_stop: CG.Label := CG.No_label; info: CG.Var := NIL; ex: ESet.T := NIL) = BEGIN WITH z = stack[tos] DO z.kind := k; z.saved := FALSE; z.outermost := FALSE; z.returnSeen := FALSE; z.exitSeen := FALSE; z.start := l_start; z.stop := l_stop; z.info := info; z.type := NIL; z.variable := NIL; z.e_set := ex; z.next := NIL; z.callConv := NIL; END; INC (tos); END Push;
PROCEDURE------------------------------------------------------ misc. predicates ---PushFrame (frame: CG.Var; class: M3RT.HandlerClass) = VAR stack := frame_stack; push: Procedure.T; BEGIN CG.Load_intt (ORD (class)); CG.Store_int (frame, M3RT.EF_class); IF Target.Global_handler_stack THEN IF (stack = NIL) THEN stack := GetFrameStack () END; CG.Load_addr (stack); CG.Store_addr (frame, M3RT.EF_next); CG.Load_addr_of (frame, 0, Target.Address.align); CG.Store_addr (stack); ELSE push := Runtime.LookUpProc (Runtime.Hook.PushEFrame); Procedure.StartCall (push); CG.Load_addr_of (frame, 0, Target.Address.align); CG.Pop_param (CG.Type.Addr); EVAL Procedure.EmitCall (push); END; END PushFrame; PROCEDUREPopFrame (frame: CG.Var) = VAR stack := frame_stack; pop: Procedure.T; BEGIN IF Target.Global_handler_stack THEN IF (stack = NIL) THEN stack := GetFrameStack () END; CG.Load_addr (frame, M3RT.EF_next); CG.Store_addr (stack); ELSE pop := Runtime.LookUpProc (Runtime.Hook.PopEFrame); Procedure.StartCall (pop); CG.Load_addr (frame, M3RT.EF_next); CG.Pop_param (CG.Type.Addr); EVAL Procedure.EmitCall (pop); END; END PopFrame; PROCEDUREGetFrameStack (): CG.Var = BEGIN frame_stack := CG.Import_global (M3ID.Add ("RTThread__handlerStack"), Target.Address.size, Target.Address.align, CG.Type.Addr, 0); RETURN frame_stack; END GetFrameStack; PROCEDURESetLock (acquire: BOOLEAN; var: CG.Var; offset: INTEGER) = CONST Hook = ARRAY BOOLEAN OF Runtime.Hook { Runtime.Hook.Unlock, Runtime.Hook.Lock }; VAR proc := Runtime.LookUpProc (Hook [acquire]); BEGIN Procedure.StartCall (proc); CG.Load_addr (var, offset); CG.Pop_param (CG.Type.Addr); EVAL Procedure.EmitCall (proc); END SetLock; PROCEDURECallFinallyHandler (info: CG.Var) = BEGIN CG.Start_call_indirect (CG.Type.Void, Target.DefaultCall); CG.Load_addr (info, M3RT.EF2_frame); CG.Pop_static_link (); CG.Load_addr (info, M3RT.EF2_handler); CG.Call_indirect (CG.Type.Void, Target.DefaultCall); END CallFinallyHandler; PROCEDURECaptureState (frame: CG.Var; handler: CG.Label) = VAR new: BOOLEAN; BEGIN IF (setjmp = NIL) THEN setjmp := CG.Import_procedure (M3ID.Add (Target.Setjmp), 1, CG.Type.Int, Target.DefaultCall, new); IF (new) THEN EVAL CG.Declare_param (M3ID.Add ("jmpbuf"), Target.Jumpbuf_size, Target.Address.align, CG.Type.Struct, 0, in_memory := TRUE,up_level := FALSE, f := CG.Never); END; END; CG.Start_call_direct (setjmp, 0, CG.Type.Int); CG.Load_addr_of (frame, M3RT.EF1_jmpbuf, Target.Jumpbuf_align); CG.Pop_param (CG.Type.Addr); CG.Call_direct (setjmp, CG.Type.Int); CG.If_true (handler, CG.Never); END CaptureState;
PROCEDURE------------------------------------------------------- code generation ---ExitOK (): BOOLEAN = BEGIN FOR i := tos - 1 TO 0 BY -1 DO IF (stack[i].kind = Kind.zEXIT) THEN RETURN TRUE END; IF (stack[i].kind = Kind.zPROC) THEN RETURN FALSE END; END; RETURN FALSE; END ExitOK; PROCEDUREReturnOK (): BOOLEAN = BEGIN FOR i := tos - 1 TO 0 BY -1 DO IF (stack[i].kind = Kind.zPROC) THEN RETURN TRUE END; END; RETURN FALSE; END ReturnOK; PROCEDUREReturnVar (VAR(*OUT*) t: Type.T; VAR(*OUT*) v: Variable.T) = BEGIN FOR i := tos - 1 TO 0 BY -1 DO WITH z = stack[i] DO IF (z.kind = Kind.zPROC) THEN t := z.type; v := z.variable; RETURN; END; END; END; <* ASSERT FALSE *> END ReturnVar;
PROCEDURE----------------------------------------------------------------- misc. ---EmitExit () = VAR i: INTEGER; BEGIN (* mark every frame out to the loop boundary as 'exitSeen' *) i := tos - 1; WHILE (i >= 0) DO WITH z = stack[i] DO z.exitSeen := TRUE; IF (z.kind = Kind.zEXIT) OR (z.kind = Kind.zTRYELSE) THEN EXIT END; END; DEC (i); END; IF Target.Has_stack_walker THEN EmitExit1 (); ELSE EmitExit2 (); END; END EmitExit; PROCEDUREEmitExit1 () = VAR i: INTEGER; BEGIN (* unwind as far as possible *) i := tos - 1; WHILE (i >= 0) DO WITH z = stack[i] DO CASE z.kind OF | Kind.zTRYELSE => CG.Load_intt (Exit_exception); CG.Store_int (z.info); CG.Jump (z.stop); EXIT; | Kind.zFINALLY, Kind.zFINALLYPROC => CG.Load_intt (Exit_exception); CG.Store_int (z.info); CG.Jump (z.stop); EXIT; | Kind.zLOCK => SetLock (FALSE, z.info, 0); | Kind.zEXIT => CG.Jump (z.stop); EXIT; | Kind.zTRY => (* ignore *) | Kind.zRAISES, Kind.zPROC => Error.Msg ("INTERNAL ERROR: EXIT not in loop"); <* ASSERT FALSE *> (* EXIT; *) END; END; DEC (i); END; END EmitExit1; PROCEDUREEmitExit2 () = VAR i: INTEGER; BEGIN (* unwind as far as possible *) i := tos - 1; WHILE (i >= 0) DO WITH z = stack[i] DO CASE z.kind OF | Kind.zTRYELSE, Kind.zFINALLY => PopFrame (z.info); CG.Load_intt (Exit_exception); CG.Store_int (z.info, M3RT.EF1_exception); CG.Jump (z.stop); EXIT; | Kind.zFINALLYPROC => PopFrame (z.info); CallFinallyHandler (z.info); | Kind.zLOCK => PopFrame (z.info); SetLock (FALSE, z.info, M3RT.EF4_mutex); | Kind.zEXIT => CG.Jump (z.stop); EXIT; | Kind.zTRY => PopFrame (z.info); | Kind.zRAISES, Kind.zPROC => Error.Msg ("INTERNAL ERROR: EXIT not in loop"); <* ASSERT FALSE *> (* EXIT; *) END; END; DEC (i); END; END EmitExit2; PROCEDUREEmitReturn (expr: Expr.T; fromFinally: BOOLEAN) = VAR i: INTEGER; ret_var: Variable.T; ret_type: Type.T; simple: BOOLEAN; is_large: BOOLEAN; BEGIN (* mark every frame out to the procedure boundary as 'returnSeen' *) i := tos - 1; WHILE (i >= 0) DO WITH z = stack[i] DO z.returnSeen := TRUE; IF (z.kind = Kind.zPROC) OR (z.kind = Kind.zTRYELSE) THEN EXIT END; END; DEC (i); END; IF (expr # NIL) THEN (* check to see if the return value is absorbed by TRY-EXCEPT-ELSE or munged by a finally handler *) simple := TRUE; i := tos-1; WHILE (i >= 0) DO WITH z = stack[i] DO CASE z.kind OF | Kind.zTRYELSE => Expr.Prep (expr); Expr.Compile (expr); CG.Discard (Type.CGType (Expr.TypeOf (expr))); expr := NIL; EXIT; | Kind.zFINALLY, Kind.zFINALLYPROC, Kind.zLOCK => simple := FALSE; | Kind.zPROC => ret_var := z.variable; ret_type := z.type; EXIT; ELSE (* ignore *) END; (*CASE*) END; (*WITH*) DEC (i); END; IF (expr # NIL) THEN (* stuff the pending return value *) Expr.Prep (expr); is_large := ProcType.LargeResult (ret_type); IF is_large OR NOT simple THEN Variable.LoadLValue (ret_var); AssignStmt.Emit (ret_type, expr); END; END; END; IF Target.Has_stack_walker THEN i := EmitReturn1 (); ELSE i := EmitReturn2 (); END; IF i >= 0 THEN WITH z = stack[i] DO IF (z.type = NIL) THEN (* there's no return value *) CG.Exit_proc (CG.Type.Void); ELSIF fromFinally THEN (* the return value is already stuffed in 'z.variable', but 'expr' is 'NIL' on this call... *) IF NOT ProcType.LargeResult (z.type) THEN Variable.Load (z.variable); CG.Exit_proc (Type.CGType (z.type)); ELSIF (z.callConv.standard_structs) THEN CG.Exit_proc (CG.Type.Void); ELSE Variable.LoadLValue (z.variable); CG.Exit_proc (CG.Type.Struct); END; ELSIF is_large THEN IF (z.callConv.standard_structs) THEN CG.Exit_proc (CG.Type.Void); ELSE Variable.LoadLValue (z.variable); CG.Exit_proc (CG.Type.Struct); END; ELSIF simple THEN AssignStmt.EmitCheck (z.type, expr); CG.Exit_proc (Type.CGType (z.type)); ELSE (* small scalar return value *) Variable.Load (z.variable); CG.Exit_proc (Type.CGType (z.type)); END; END; END; END EmitReturn; PROCEDUREEmitReturn1 (): INTEGER = VAR i: INTEGER; BEGIN (* now, unwind as far as possible *) i := tos - 1; WHILE (i >= 0) DO WITH z = stack[i] DO CASE z.kind OF | Kind.zTRYELSE => CG.Load_intt (Return_exception); CG.Store_int (z.info); CG.Jump (z.stop); EXIT; | Kind.zFINALLY, Kind.zFINALLYPROC => CG.Load_intt (Return_exception); CG.Store_int (z.info); CG.Jump (z.stop); EXIT; | Kind.zLOCK => SetLock (FALSE, z.info, 0); | Kind.zEXIT => (* ignore *) | Kind.zTRY => (* ignore *) | Kind.zRAISES => (* ignore *) | Kind.zPROC => RETURN i; END; END; DEC (i); END; RETURN -1; END EmitReturn1; PROCEDUREEmitReturn2 (): INTEGER = VAR i: INTEGER; BEGIN (* now, unwind as far as possible *) i := tos - 1; WHILE (i >= 0) DO WITH z = stack[i] DO CASE z.kind OF | Kind.zTRYELSE => PopFrame (z.info); CG.Load_nil (); (* the current "RETURN" exception is lost *) CG.Store_addr (z.info, M3RT.EF1_exception); CG.Jump (z.stop); EXIT; | Kind.zFINALLY => PopFrame (z.info); CG.Load_intt (Return_exception); CG.Store_int (z.info, M3RT.EF1_exception); CG.Jump (z.stop); EXIT; | Kind.zFINALLYPROC => PopFrame (z.info); CallFinallyHandler (z.info); | Kind.zLOCK => PopFrame (z.info); SetLock (FALSE, z.info, M3RT.EF4_mutex); | Kind.zEXIT => (* ignore *) | Kind.zTRY => PopFrame (z.info); | Kind.zRAISES => PopFrame (z.info); | Kind.zPROC => RETURN i; END; END; DEC (i); END; RETURN -1; END EmitReturn2; PROCEDUREEmitScopeTable (): INTEGER = VAR Align := MAX (Target.Address.align, Target.Integer.align); f: FramePtr := all_frames; base, x, size: INTEGER; e_base: CG.Var; e_offset: INTEGER; BEGIN IF (f = NIL) OR (NOT Target.Has_stack_walker) THEN RETURN 0 END; (* make sure that all the exception lists were declared *) WHILE (f # NIL) DO IF (f.e_set # NIL) THEN ESet.Declare (f.e_set) END; f := f.next; END; (* declare space for the table *) size := n_frames * M3RT.EX_SIZE; base := Module.Allocate (size, Align, "*exception scopes*"); CG.Comment (base, "exception scopes"); (* fill in the table *) f := all_frames; x := base; WHILE (f # NIL) DO CG.Init_intt (x + M3RT.EX_class, Target.Char.size, RT_Kind [f.kind]); IF (f.outermost) THEN CG.Init_intt (x + M3RT.EX_outermost, Target.Char.size, ORD(TRUE)); END; IF (f.next = NIL) THEN CG.Init_intt (x + M3RT.EX_end_of_list, Target.Char.size, ORD(TRUE)); END; CG.Init_label (x + M3RT.EX_start, f.start); CG.Init_label (x + M3RT.EX_stop, f.stop); IF (f.info # NIL) THEN CG.Init_offset (x + M3RT.EX_offset, f.info) END; IF (f.e_set # NIL) THEN ESet.GetAddress (f.e_set, e_base, e_offset); IF (e_base # NIL) OR (e_offset # 0) THEN CG.Init_var (x + M3RT.EX_excepts, e_base, e_offset); END; END; INC (x, M3RT.EX_SIZE); f := f.next; END; RETURN base; END EmitScopeTable; PROCEDUREEmitExceptionTest (signature: Type.T) = VAR ex := ProcType.Raises (signature); i: INTEGER; BEGIN IF NOT Target.Has_stack_walker THEN RETURN END; IF ESet.RaisesNone (ex) THEN RETURN END; (* scan the frame stack looking for the first active handler *) i := tos - 1; LOOP IF (i < 0) THEN RETURN END; WITH z = stack[i] DO CASE z.kind OF | Kind.zTRYELSE => EXIT; | Kind.zFINALLYPROC => (* ignore the runtime does it *) | Kind.zFINALLY => EXIT; | Kind.zLOCK => (* ignore (the runtime does the unlocks) *) | Kind.zEXIT => (* ignore *) | Kind.zTRY => EXIT; | Kind.zRAISES => (* ignore *) | Kind.zPROC => RETURN; (* didn't find any relevent handlers *) END; END; DEC (i); END; (* generate the conditional branch to the handler *) CG.Load_addr (stack[i].info, M3RT.EI_exception); CG.Load_nil (); CG.If_ne (stack[i].stop, CG.Type.Addr, CG.Never); END EmitExceptionTest; PROCEDURENextHandler (VAR(*OUT*) handler: CG.Label; VAR(*OUT*) info: CG.Var): BOOLEAN = VAR i: INTEGER; BEGIN IF NOT Target.Has_stack_walker THEN RETURN FALSE END; (* scan the frame stack looking for the first active handler *) i := tos - 1; LOOP IF (i < 0) THEN RETURN FALSE END; WITH z = stack[i] DO CASE z.kind OF | Kind.zTRYELSE => EXIT; | Kind.zFINALLYPROC => (* ignore the runtime does it *) | Kind.zFINALLY => EXIT; | Kind.zLOCK => (* ignore (the runtime does the unlocks) *) | Kind.zEXIT => (* ignore *) | Kind.zTRY => EXIT; | Kind.zRAISES => (* ignore *) | Kind.zPROC => RETURN FALSE; (* didn't find any handlers *) END; END; DEC (i); END; handler := stack[i].stop; info := stack[i].info; RETURN TRUE; END NextHandler;
PROCEDUREReset () = BEGIN all_frames := NIL; n_frames := 0; save_depth := 0; frame_stack := NIL; setjmp := NIL; tos := 0; END Reset; BEGIN END Marker.