(* Copyright (C) 1992, Digital Equipment Corporation           *)
(* All rights reserved.                                        *)
(* See the file COPYRIGHT for a full description.              *)

(* File: Marker.m3                                             *)
(* Last modified on Wed Apr 15 09:47:26 PDT 1992 by kalsow     *)
(*      modified on Fri Feb 15 03:21:08 1991 by muller         *)

MODULE Marker;

IMPORT M3, Error, Emit, Type, Variable, ProcType, Temp;

TYPE
  Kind = {zFINALLY, zFINALLYPROC, zLOCK, zEXIT, zTRY, zTRYELSE,
           zRAISES, zPROC};

  Marker = RECORD
    kind       : Kind;
    label      : Label;
    returnSeen : BOOLEAN;
    exitSeen   : BOOLEAN;
    type       : Type.T;     (* kind = PROC *)
    variable   : Variable.T; (* kind = PROC *)
  END;

CONST
  NoHandler =  -1;

VAR
  tos   : INTEGER := 0;
  stack : ARRAY [0..50] OF Marker;

<*INLINE*> PROCEDURE Pop () =
  BEGIN
    DEC (tos);
  END Pop;

(******************  TRY-FINALLY  *******************************)

PROCEDURE PushFinally (x: Label) =
  BEGIN
    Push (Kind.zFINALLY, x);
  END PushFinally;

PROCEDURE PushFinallyProc (x: Label) =
  BEGIN
    Push (Kind.zFINALLYPROC, x);
  END PushFinallyProc;

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

(******************  LOCK-END  *******************************)

PROCEDURE PushLock (x: Label) =
  BEGIN
    Push (Kind.zLOCK, x);
  END PushLock;

(******************  TRY-EXCEPT  *******************************)

PROCEDURE PushTry (x: Label) =
  BEGIN
    Push (Kind.zTRY, x);
  END PushTry;

PROCEDURE PushTryElse (x: Label) =
  BEGIN
    Push (Kind.zTRYELSE, x);
  END PushTryElse;

(*****************************************************************
PROCEDURE EmitReraise (current: INTEGER) =
  VAR i, x, pending: INTEGER;
  BEGIN
    (* unwind as far as possible to reraise an exception *)
    pending := NoHandler; (* last frame that needs a cut *)
    i := tos - 1;
    WHILE (i >= 0) DO
      WITH z = stack[i] DO
        x := z.label;
        CASE z.kind OF
        | Kind.zFINALLY, Kind.zTRY, Kind.zTRYELSE =>
            Emit.OpI  ("_CUT_TO_NEXT_HANDLER (_h@);\n", x);
            Emit.OpII ("_h@.exception = _h@.exception;\n", x, current);
            Emit.OpII ("_h@.arg       = _h@.arg;\n", x, current);
            Emit.OpL  ("goto @;\n", x);
            pending := NoHandler;
            EXIT;
        | Kind.zFINALLYPROC =>
            Emit.OpI  ("_CUT_TO_NEXT_HANDLER (_h@);\n", x);
            Emit.OpII ("_FINALLY_@ (_h@.frame);\n", x, x);
            pending := NoHandler;
        | Kind.zLOCK =>
            Emit.OpI ("Thread__Release (_h@.mutex);\n", x);
            pending := z.label;
        | Kind.zEXIT =>
            (* ignore *)
        | Kind.zRAISES =>
            pending := z.label;
        | Kind.zPROC =>
            IF (pending # NoHandler) THEN
              Emit.OpI  ("_CUT_TO_NEXT_HANDLER (_h@);\n", pending);
            END;
            Emit.OpII ("_RAISE_FOR_SURE (_h@.exception, _h@.arg);\n",
                         current, current);
            EXIT;
        END;
      END;
      DEC (i);
    END;
  END EmitReraise;
*********************************************************************)

(******************  LOOP-EXIT  *******************************)

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

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 EmitExit () =
  VAR i, x, pending: 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;

    (* now, unwind as far as possible *)
    pending := NoHandler; (* last frame that needs a cut *)
    i := tos - 1;
    WHILE (i >= 0) DO
      WITH z = stack[i] DO
        x := z.label;
        CASE z.kind OF
        | Kind.zFINALLY, Kind.zTRYELSE =>
            Emit.OpI  ("_CUT_TO_NEXT_HANDLER (_h@);\n", x);
            Emit.OpI ("_h@.exception = _EXIT_EXCEPTION;\n", x);
            Emit.OpL ("goto @;\n", x);
            pending := NoHandler;
            EXIT;
        | Kind.zFINALLYPROC =>
            Emit.OpI  ("_CUT_TO_NEXT_HANDLER (_h@);\n", x);
            Emit.OpII ("_FINALLY_@ (_h@.frame);\n", x, x);
            pending := NoHandler;
        | Kind.zLOCK =>
            Emit.OpI ("Thread__Release (_h@.mutex);\n", x);
            pending := z.label;
        | Kind.zEXIT =>
            IF (pending # NoHandler) THEN
              Emit.OpI ("_CUT_TO_NEXT_HANDLER (_h@);\n", pending);
            END;
            Emit.OpL ("goto @;\n", x);
            EXIT;
        | Kind.zTRY =>
            pending := z.label;
        | Kind.zRAISES, Kind.zPROC =>
            Error.Msg ("INTERNAL ERROR: EXIT not in loop");
            <* ASSERT FALSE *>
            (* EXIT; *)
        END;
      END;
      DEC (i);
    END;
  END EmitExit;

(******************  TRY-PASSING  *******************************)

PROCEDURE PushRaises (x: Label) =
  BEGIN
    Push (Kind.zRAISES, x);
  END PushRaises;

(******************  PROCEDURES *******************************)

PROCEDURE PushProcedure (t: Type.T;  v: Variable.T) =
  VAR x: Label;
  BEGIN
    <* ASSERT (t = NIL) = (v = NIL) *>
    x := M3.NextLabel;  INC (M3.NextLabel);
    Push (Kind.zPROC, x);
    WITH z = stack[tos - 1] DO
      z.type := t;
      z.variable := v;
    END;
  END PushProcedure;

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
      IF (stack[i].kind = Kind.zPROC) THEN
        t := stack[i].type;
        v := stack[i].variable;
        RETURN ;
      END;
    END;
    <* ASSERT FALSE *>
  END ReturnVar;

PROCEDURE EmitReturn (val: Temp.T;  type: Type.T) =
  VAR i, x, pending: INTEGER;
  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;

    (* now, unwind as far as possible *)
    pending := NoHandler; (* last frame that needs a cut *)
    i := tos - 1;
    WHILE (i >= 0) DO
      WITH z = stack[i] DO
        x := z.label;
        CASE z.kind OF
        | Kind.zFINALLY =>
            StuffResult (val, type);
            Emit.OpI  ("_CUT_TO_NEXT_HANDLER (_h@);\n", x);
            Emit.OpI ("_h@.exception = _RETURN_EXCEPTION;\n", x);
            Emit.OpL ("goto @;\n", x);
            pending := NoHandler;
            EXIT;
        | Kind.zTRYELSE =>
            val := NIL; (* the current "RETURN" is lost... *)
            Emit.OpI  ("_CUT_TO_NEXT_HANDLER (_h@);\n", x);
            Emit.OpI ("_h@.exception = _RETURN_EXCEPTION;\n", x);
            Emit.OpL ("goto @;\n", x);
            pending := NoHandler;
            EXIT;
        | Kind.zFINALLYPROC =>
            StuffResult (val, type);
            Emit.OpI  ("_CUT_TO_NEXT_HANDLER (_h@);\n", x);
            Emit.OpII ("_FINALLY_@ (_h@.frame);\n", x, x);
            pending := NoHandler;
        | Kind.zLOCK =>
            Emit.OpI ("Thread__Release (_h@.mutex);\n", x);
            pending := z.label;
        | Kind.zEXIT =>
            (* ignore *)
        | Kind.zTRY, Kind.zRAISES =>
            pending := z.label;
        | Kind.zPROC =>
            IF (pending # NoHandler) THEN
              Emit.OpI ("_CUT_TO_NEXT_HANDLER (_h@);\n", pending);
            END;
            IF (z.type = NIL) THEN
              Emit.Op ("return;\n");
            ELSIF ProcType.LargeResult (z.type) THEN
              IF (val = NIL) THEN
                Emit.OpV ("*_return = @;\n", z.variable);
              ELSE
                Emit.Op ("*_return = ");
                IF Type.Name (z.type) # Type.Name (type) THEN
                  Emit.OpF ("(@)", z.type);
                END;
                Emit.OpT ("@;\n", val);
              END;
              Emit.Op  ("return;\n");
            ELSE
              IF (val = NIL) THEN
                Emit.OpV ("return @;\n", z.variable);
              ELSE
                Emit.Op ("return ");
                IF Type.Name (z.type) # Type.Name (type) THEN
                  Emit.OpF ("(@)", z.type);
                END;
                Emit.OpT ("@;\n", val);
              END;
            END;
            EXIT;
        END;
      END;
      DEC (i);
    END;
  END EmitReturn;

PROCEDURE StuffResult (VAR val: Temp.T;  type: Type.T) =
(* stuff the pending return value so that subsequent finally handlers
   can mutate it. *)
  VAR v: Variable.T;  t: Type.T;
  BEGIN
    IF (val # NIL) THEN
      ReturnVar (t, v);
      Emit.OpV ("@ = ", v);
      IF Type.Name (t) # Type.Name (type) THEN
        Emit.OpF ("(@)", t);
      END;
      Emit.OpT ("@;\n", val);
      val := NIL;
    END;
  END StuffResult;

(******************  INTERNAL  *******************************)

PROCEDURE Push (k: Kind;   x: Label) =
  BEGIN
    WITH z = stack[tos] DO
      z.kind       := k;
      z.label      := x;
      z.returnSeen := FALSE;
      z.exitSeen   := FALSE;
      z.type       := NIL;
      z.variable   := NIL;
    END;
    INC (tos);
  END Push;

PROCEDURE Reset () =
  BEGIN
    tos := 0;
  END Reset;

BEGIN
END Marker.