------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                     SYSTEM.MACHINE_STATE_OPERATIONS                      --
--                                                                          --
--                                 B o d y                                  --
--                         (Version for IRIX/MIPS)                          --
--                                                                          --
--          Copyright (C) 1999-2004 Free Software Foundation, Inc.          --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  This version of Ada.Exceptions.Machine_State_Operations is for use on
--  SGI Irix systems. By means of compile time conditional calculations, it
--  can handle both n32/n64 and o32 modes.

with System.Machine_Code; use System.Machine_Code;
with System.Memory;
with System.Soft_Links; use System.Soft_Links;
with Unchecked_Conversion;

package body System.Machine_State_Operations is

   use System.Storage_Elements;
   use System.Exceptions;

   --  The exc_unwind function in libexc operats on a Sigcontext

   --  Type sigcontext_t is defined in /usr/include/sys/signal.h.
   --  We define an equivalent Ada type here. From the comments in
   --  signal.h:

   --    sigcontext is not part of the ABI - so this version is used to
   --    handle 32 and 64 bit applications - it is a constant size regardless
   --    of compilation mode, and always returns 64 bit register values

   type Uns32 is mod 2 ** 32;
   type Uns64 is mod 2 ** 64;

   type Uns32_Ptr is access all Uns32;
   type Uns64_Array is array (Integer range <>) of Uns64;

   type Reg_Array is array (0 .. 31) of Uns64;

   type Sigcontext is record
      SC_Regmask           : Uns32;          --  0
      SC_Status            : Uns32;          --  4
      SC_PC                : Uns64;          --  8
      SC_Regs              : Reg_Array;      --  16
      SC_Fpregs            : Reg_Array;      --  272
      SC_Ownedfp           : Uns32;          --  528
      SC_Fpc_Csr           : Uns32;          --  532
      SC_Fpc_Eir           : Uns32;          --  536
      SC_Ssflags           : Uns32;          --  540
      SC_Mdhi              : Uns64;          --  544
      SC_Mdlo              : Uns64;          --  552
      SC_Cause             : Uns64;          --  560
      SC_Badvaddr          : Uns64;          --  568
      SC_Triggersave       : Uns64;          --  576
      SC_Sigset            : Uns64;          --  584
      SC_Fp_Rounded_Result : Uns64;          --  592
      SC_Pancake           : Uns64_Array (0 .. 5);
      SC_Pad               : Uns64_Array (0 .. 26);
   end record;

   type Sigcontext_Ptr is access all Sigcontext;

   SC_Regs_Pos   : constant String := "16";
   SC_Fpregs_Pos : constant String := "272";
   --  Byte offset of the Integer and Floating Point register save areas
   --  within the Sigcontext.

   function To_Sigcontext_Ptr is
     new Unchecked_Conversion (Machine_State, Sigcontext_Ptr);

   type Addr_Int is mod 2 ** Long_Integer'Size;
   --  An unsigned integer type whose size is the same as System.Address.
   --  We rely on the fact that Long_Integer'Size = System.Address'Size in
   --  all ABIs.  Type Addr_Int can be converted to Uns64.

   function To_Code_Loc is new Unchecked_Conversion (Addr_Int, Code_Loc);
   function To_Addr_Int is new Unchecked_Conversion (System.Address, Addr_Int);
   function To_Uns32_Ptr is new Unchecked_Conversion (Addr_Int, Uns32_Ptr);

   --------------------------------
   -- ABI-Dependent Declarations --
   --------------------------------

   o32  : constant Boolean := System.Word_Size = 32;
   n32  : constant Boolean := System.Word_Size = 64;
   o32n : constant Natural := Boolean'Pos (o32);
   n32n : constant Natural := Boolean'Pos (n32);
   --  Flags to indicate which ABI is in effect for this compilation. For the
   --  purposes of this unit, the n32 and n64 ABI's are identical.

   LSC : constant Character := Character'Val (o32n * Character'Pos ('w') +
                                              n32n * Character'Pos ('d'));
   --  This is 'w' for o32, and 'd' for n32/n64, used for constructing the
   --  load/store instructions used to save/restore machine instructions.

   Roff : constant Character := Character'Val (o32n * Character'Pos ('4') +
                                               n32n * Character'Pos ('0'));
   --  Offset from first byte of a __uint64 register save location where
   --  the register value is stored.  For n32/64 we store the entire 64
   --  bit register into the uint64.  For o32, only 32 bits are stored
   --  at an offset of 4 bytes. This is used as part of expressions with
   --  '+' signs on both sides, so a null offset has to be '0' and not ' '
   --  to avoid assembler syntax errors on "X + + Y" in the latter case.

   procedure Update_GP (Scp : Sigcontext_Ptr);

   ---------------
   -- Update_GP --
   ---------------

   procedure Update_GP (Scp : Sigcontext_Ptr) is

      type F_op  is mod 2 ** 6;
      type F_reg is mod 2 ** 5;
      type F_imm is new Short_Integer;

      type I_Type is record
         op    : F_op;
         rs    : F_reg;
         rt    : F_reg;
         imm   : F_imm;
      end record;

      pragma Pack (I_Type);
      for I_Type'Size use 32;

      type I_Type_Ptr is access all I_Type;

      LW : constant F_op := 2#100011#;
      Reg_GP : constant := 28;

      type Address_Int is mod 2 ** Standard'Address_Size;
      function To_I_Type_Ptr is new
        Unchecked_Conversion (Address_Int, I_Type_Ptr);

      Ret_Ins : constant I_Type_Ptr := To_I_Type_Ptr (Address_Int (Scp.SC_PC));
      GP_Ptr  : Uns32_Ptr;

   begin
      if Ret_Ins.op = LW and then Ret_Ins.rt = Reg_GP then
         GP_Ptr := To_Uns32_Ptr
           (Addr_Int (Scp.SC_Regs (Integer (Ret_Ins.rs)))
            + Addr_Int (Ret_Ins.imm));
         Scp.SC_Regs (Reg_GP) := Uns64 (GP_Ptr.all);
      end if;
   end Update_GP;

   ----------------------------
   -- Allocate_Machine_State --
   ----------------------------

   function Allocate_Machine_State return Machine_State is
   begin
      return Machine_State
        (Memory.Alloc (Sigcontext'Max_Size_In_Storage_Elements));
   end Allocate_Machine_State;

   -------------------
   -- Enter_Handler --
   -------------------

   procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
      pragma Warnings (Off, M);
      pragma Warnings (Off, Handler);

      LOADI : constant String (1 .. 2) := 'l' & LSC;
      --  This is "lw" in o32 mode, and "ld" in n32/n64 mode

      LOADF : constant String (1 .. 4) := 'l' & LSC & "c1";
      --  This is "lwc1" in o32 mode and "ldc1" in n32/n64 mode

   begin
      --  Restore integer registers from machine state. Note that we know
      --  that $4 points to M, and $5 points to Handler, since this is
      --  the standard calling sequence

      Asm (LOADI & " $16,  16*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (LOADI & " $17,  17*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (LOADI & " $18,  18*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (LOADI & " $19,  19*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (LOADI & " $20,  20*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (LOADI & " $21,  21*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (LOADI & " $22,  22*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (LOADI & " $23,  23*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (LOADI & " $24,  24*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (LOADI & " $25,  25*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (LOADI & " $26,  26*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (LOADI & " $27,  27*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (LOADI & " $28,  28*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (LOADI & " $29,  29*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (LOADI & " $30,  30*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (LOADI & " $31,  31*8+" & Roff & "+" & SC_Regs_Pos & "($4)");

      --  Restore floating-point registers from machine state

      Asm (LOADF & " $f16, 16*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (LOADF & " $f17, 17*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (LOADF & " $f18, 18*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (LOADF & " $f19, 19*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (LOADF & " $f20, 20*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (LOADF & " $f21, 21*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (LOADF & " $f22, 22*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (LOADF & " $f23, 23*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (LOADF & " $f24, 24*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (LOADF & " $f25, 25*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (LOADF & " $f26, 26*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (LOADF & " $f27, 27*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (LOADF & " $f28, 28*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (LOADF & " $f29, 29*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (LOADF & " $f30, 30*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (LOADF & " $f31, 31*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");

      --  Jump directly to the handler

      Asm ("jr  $5");
   end Enter_Handler;

   ----------------
   -- Fetch_Code --
   ----------------

   function Fetch_Code (Loc : Code_Loc) return Code_Loc is
   begin
      return Loc;
   end Fetch_Code;

   ------------------------
   -- Free_Machine_State --
   ------------------------

   procedure Free_Machine_State (M : in out Machine_State) is
   begin
      Memory.Free (Address (M));
      M := Machine_State (Null_Address);
   end Free_Machine_State;

   ------------------
   -- Get_Code_Loc --
   ------------------

   function Get_Code_Loc (M : Machine_State) return Code_Loc is
      SC : constant Sigcontext_Ptr := To_Sigcontext_Ptr (M);
   begin
      return To_Code_Loc (Addr_Int (SC.SC_PC));
   end Get_Code_Loc;

   --------------------------
   -- Machine_State_Length --
   --------------------------

   function Machine_State_Length return Storage_Offset is
   begin
      return Sigcontext'Max_Size_In_Storage_Elements;
   end Machine_State_Length;

   ---------------
   -- Pop_Frame --
   ---------------

   procedure Pop_Frame
     (M    : Machine_State;
      Info : Subprogram_Info_Type)
   is
      pragma Warnings (Off, Info);

      Scp : constant Sigcontext_Ptr := To_Sigcontext_Ptr (M);

      procedure Exc_Unwind (Scp : Sigcontext_Ptr; Fde : Long_Integer := 0);
      pragma Import (C, Exc_Unwind, "exc_unwind");

      --  ??? Calling exc_unwind in the current setup does not work and
      --  triggers the emission of system warning messages. Why it does
      --  not work remains to be investigated. Part of the problem is
      --  probably a section naming issue (e.g. .eh_frame/.debug_frame).

      --  Instead of letting the call take place for nothing and emit
      --  messages we don't expect, we just arrange things to pretend it
      --  occurred and failed.

      --  ??? Until this is fixed, we shall document that the backtrace
      --  computation facility does not work, and we inhibit the pragma below
      --  because we arrange for the call not to be emitted and the linker
      --  complains when a library is linked in but resolves nothing.

      --  pragma Linker_Options ("-lexc");

   begin
      --  exc_unwind is apparently not thread-safe under IRIX, so protect it
      --  against race conditions within the GNAT run time.
      --  ??? Note that we might want to use a fine grained lock here since
      --  Lock_Task is used in many other places.

      Lock_Task.all;

      if False then
         Exc_Unwind (Scp);
      else
         Scp.SC_PC := 0;
      end if;

      Unlock_Task.all;

      if Scp.SC_PC = 0 or else Scp.SC_PC = 1 then

         --  A return value of 0 or 1 means exc_unwind couldn't find a parent
         --  frame. Propagate_Exception expects a zero return address to
         --  indicate TOS.

         Scp.SC_PC := 0;

      else
         --  Set the GP to restore to the caller value (not callee value)
         --  This is done only in o32 mode. In n32/n64 mode, GP is a normal
         --  callee save register

         if o32 then
            Update_GP (Scp);
         end if;

         --  Adjust the return address to the call site, not the
         --  instruction following the branch delay slot.  This may
         --  be necessary if the last instruction of a pragma No_Return
         --  subprogram is a call. The first instruction following the
         --  delay slot may be the start of another subprogram. We back
         --  off the address by 8, which points safely into the middle
         --  of the generated subprogram code, avoiding end effects.

         Scp.SC_PC := Scp.SC_PC - 8;
      end if;
   end Pop_Frame;

   -----------------------
   -- Set_Machine_State --
   -----------------------

   procedure Set_Machine_State (M : Machine_State) is

      STOREI : constant String (1 .. 2) := 's' & LSC;
      --  This is "sw" in o32 mode, and "sd" in n32 mode

      STOREF : constant String (1 .. 4) := 's' & LSC & "c1";
      --  This is "swc1" in o32 mode and "sdc1" in n32 mode

      Scp : Sigcontext_Ptr;

   begin
      --  Save the integer registers. Note that we know that $4 points
      --  to M, since that is where the first parameter is passed.
      --  Restore integer registers from machine state. Note that we know
      --  that $4 points to M since this is the standard calling sequence

      <<Past_Prolog>>

      Asm (STOREI & " $16,  16*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (STOREI & " $17,  17*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (STOREI & " $18,  18*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (STOREI & " $19,  19*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (STOREI & " $20,  20*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (STOREI & " $21,  21*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (STOREI & " $22,  22*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (STOREI & " $23,  23*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (STOREI & " $24,  24*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (STOREI & " $25,  25*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (STOREI & " $26,  26*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (STOREI & " $27,  27*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (STOREI & " $28,  28*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (STOREI & " $29,  29*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (STOREI & " $30,  30*8+" & Roff & "+" & SC_Regs_Pos & "($4)");
      Asm (STOREI & " $31,  31*8+" & Roff & "+" & SC_Regs_Pos & "($4)");

      --  Restore floating-point registers from machine state

      Asm (STOREF & " $f16, 16*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (STOREF & " $f17, 17*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (STOREF & " $f18, 18*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (STOREF & " $f19, 19*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (STOREF & " $f20, 20*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (STOREF & " $f21, 21*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (STOREF & " $f22, 22*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (STOREF & " $f23, 23*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (STOREF & " $f24, 24*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (STOREF & " $f25, 25*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (STOREF & " $f26, 26*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (STOREF & " $f27, 27*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (STOREF & " $f28, 28*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (STOREF & " $f29, 29*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (STOREF & " $f30, 30*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");
      Asm (STOREF & " $f31, 31*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)");

      --  Set the PC value for the context to a location after the
      --  prolog has been executed.

      Scp := To_Sigcontext_Ptr (M);
      Scp.SC_PC := Uns64 (To_Addr_Int (Past_Prolog'Address));

      --  We saved the state *inside* this routine, but what we want is
      --  the state at the call site. So we need to do one pop operation.
      --  This pop operation will properly set the PC value in the machine
      --  state, so there is no need to save PC in the above code.

      Pop_Frame (M, Set_Machine_State'Address);
   end Set_Machine_State;

   ------------------------------
   -- Set_Signal_Machine_State --
   ------------------------------

   procedure Set_Signal_Machine_State
     (M       : Machine_State;
      Context : System.Address)
   is
      pragma Warnings (Off, M);
      pragma Warnings (Off, Context);

   begin
      null;
   end Set_Signal_Machine_State;

end System.Machine_State_Operations;