m3front/src/misc/Marker.m3


Copyright (C) 1994, Digital Equipment Corp.
 File: Marker.m3                                             

MODULE Marker;

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 stack ---

PROCEDURE 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*> PROCEDURE Pop () =
  BEGIN
    DEC (tos);
    IF (stack[tos].saved) THEN DEC (save_depth) END;
    <*ASSERT save_depth >= 0*>
  END Pop;

PROCEDURE PushFinally (l_start, l_stop: CG.Label;  info: CG.Var) =
  BEGIN
    Push (Kind.zFINALLY, l_start, l_stop, info);
  END PushFinally;

PROCEDURE PushFinallyProc (l_start, l_stop: CG.Label;  info: CG.Var) =
  BEGIN
    Push (Kind.zFINALLYPROC, l_start, l_stop, info);
  END PushFinallyProc;

PROCEDURE PopFinally (VAR(*OUT*) returnSeen, exitSeen: BOOLEAN) =
  BEGIN
    Pop ();
    returnSeen := stack[tos].returnSeen;
    exitSeen   := stack[tos].exitSeen;
  END PopFinally;

PROCEDURE PushLock (l_start, l_stop: CG.Label;  mutex: CG.Var) =
  BEGIN
    Push (Kind.zLOCK, l_start, l_stop, mutex);
  END PushLock;

PROCEDURE PushTry (l_start, l_stop: CG.Label;  info: CG.Var;  ex: ESet.T) =
  BEGIN
    Push (Kind.zTRY, l_start, l_stop, info, ex);
  END PushTry;

PROCEDURE PushTryElse (l_start, l_stop: CG.Label;  info: CG.Var) =
  BEGIN
    Push (Kind.zTRYELSE, l_start, l_stop, info);
  END PushTryElse;

PROCEDURE PushExit (l_stop: CG.Label) =
  BEGIN
    Push (Kind.zEXIT, l_stop := l_stop);
  END PushExit;

PROCEDURE PushRaises (l_start, l_stop: CG.Label;  ex: ESet.T;  info: CG.Var) =
  BEGIN
    Push (Kind.zRAISES, l_start, l_stop, info, ex);
  END PushRaises;

PROCEDURE PushProcedure (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;

PROCEDURE Push (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;
--------------------------------------------- explicit frame operations ---

PROCEDURE 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;

PROCEDURE PopFrame (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;

PROCEDURE GetFrameStack (): 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;

PROCEDURE SetLock (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;

PROCEDURE CallFinallyHandler (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;

PROCEDURE CaptureState (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;
------------------------------------------------------ misc. predicates ---

PROCEDURE 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;

PROCEDURE ReturnOK (): 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;

PROCEDURE ReturnVar (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;
------------------------------------------------------- code generation ---

PROCEDURE 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;

PROCEDURE EmitExit1 () =
  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;

PROCEDURE EmitExit2 () =
  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;

PROCEDURE EmitReturn (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;

PROCEDURE EmitReturn1 (): 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;

PROCEDURE EmitReturn2 (): 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;

PROCEDURE EmitScopeTable (): 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;

PROCEDURE EmitExceptionTest (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;

PROCEDURE NextHandler (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;
----------------------------------------------------------------- misc. ---

PROCEDURE Reset () =
  BEGIN
    all_frames  := NIL;
    n_frames    := 0;
    save_depth  := 0;
    frame_stack := NIL;
    setjmp      := NIL;
    tos         := 0;
  END Reset;

BEGIN
END Marker.

interface M3ID is in: