gcc/ada/s-mastop-tru64.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                     SYSTEM.MACHINE_STATE_OPERATIONS                      --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                         (Version for Alpha/Dec Unix)                     --
   9 --                                                                          --
  10 --                     Copyright (C) 1999-2010, AdaCore                     --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  18 --                                                                          --
  19 -- As a special exception under Section 7 of GPL version 3, you are granted --
  20 -- additional permissions described in the GCC Runtime Library Exception,   --
  21 -- version 3.1, as published by the Free Software Foundation.               --
  22 --                                                                          --
  23 -- You should have received a copy of the GNU General Public License and    --
  24 -- a copy of the GCC Runtime Library Exception along with this program;     --
  25 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  26 -- <http://www.gnu.org/licenses/>.                                          --
  27 --                                                                          --
  28 -- GNAT was originally developed  by the GNAT team at  New York University. --
  29 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  30 --                                                                          --
  31 ------------------------------------------------------------------------------
  32
  33 --  This version of System.Machine_State_Operations is for use on
  34 --  Alpha systems running DEC Unix.
  35
  36 with System.Memory;
  37
  38 package body System.Machine_State_Operations is
  39
  40    pragma Linker_Options ("-lexc");
  41    --  Needed for definitions of exc_capture_context and exc_virtual_unwind
  42
  43    ----------------------------
  44    -- Allocate_Machine_State --
  45    ----------------------------
  46
  47    function Allocate_Machine_State return Machine_State is
  48       use System.Storage_Elements;
  49
  50       function c_machine_state_length return Storage_Offset;
  51       pragma Import (C, c_machine_state_length, "__gnat_machine_state_length");
  52
  53    begin
  54       return Machine_State
  55         (Memory.Alloc (Memory.size_t (c_machine_state_length)));
  56    end Allocate_Machine_State;
  57
  58    ----------------
  59    -- Fetch_Code --
  60    ----------------
  61
  62    function Fetch_Code (Loc : Code_Loc) return Code_Loc is
  63    begin
  64       return Loc;
  65    end Fetch_Code;
  66
  67    ------------------------
  68    -- Free_Machine_State --
  69    ------------------------
  70
  71    procedure Free_Machine_State (M : in out Machine_State) is
  72    begin
  73       Memory.Free (Address (M));
  74       M := Machine_State (Null_Address);
  75    end Free_Machine_State;
  76
  77    ------------------
  78    -- Get_Code_Loc --
  79    ------------------
  80
  81    function Get_Code_Loc (M : Machine_State) return Code_Loc is
  82       Asm_Call_Size : constant := 4;
  83
  84       function c_get_code_loc (M : Machine_State) return Code_Loc;
  85       pragma Import (C, c_get_code_loc, "__gnat_get_code_loc");
  86
  87       --  Code_Loc returned by c_get_code_loc is the return point but here we
  88       --  want Get_Code_Loc to return the call point. Under DEC Unix a call
  89       --  asm instruction takes 4 bytes. So we must remove this value from
  90       --  c_get_code_loc to have the call point.
  91
  92       Loc : constant Code_Loc := c_get_code_loc (M);
  93
  94    begin
  95       if Loc = 0 then
  96          return 0;
  97       else
  98          return Loc - Asm_Call_Size;
  99       end if;
 100    end Get_Code_Loc;
 101
 102    --------------------------
 103    -- Machine_State_Length --
 104    --------------------------
 105
 106    function Machine_State_Length
 107      return System.Storage_Elements.Storage_Offset
 108    is
 109       use System.Storage_Elements;
 110
 111       function c_machine_state_length return Storage_Offset;
 112       pragma Import (C, c_machine_state_length, "__gnat_machine_state_length");
 113
 114    begin
 115       return c_machine_state_length;
 116    end Machine_State_Length;
 117
 118    ---------------
 119    -- Pop_Frame --
 120    ---------------
 121
 122    procedure Pop_Frame (M : Machine_State) is
 123       procedure exc_virtual_unwind (Fcn : System.Address; M : Machine_State);
 124       pragma Import (C, exc_virtual_unwind, "exc_virtual_unwind");
 125
 126       function exc_lookup_function (Loc : Code_Loc) return System.Address;
 127       pragma Import (C, exc_lookup_function, "exc_lookup_function_entry");
 128
 129       procedure c_set_code_loc (M : Machine_State; Loc : Code_Loc);
 130       pragma Import (C, c_set_code_loc, "__gnat_set_code_loc");
 131
 132       --  Look for a code-range descriptor table containing the PC of the
 133       --  specified machine state. If we don't find any, attempting to unwind
 134       --  further would fail so we set the machine state's code location to a
 135       --  value indicating that the top of the call chain is reached. This
 136       --  happens when the function at the address pointed to by PC has not
 137       --  been registered with the unwinding machinery, as with the __istart
 138       --  functions generated by the linker in presence of initialization
 139       --  routines for example.
 140
 141       Prf : constant System.Address := exc_lookup_function (Get_Code_Loc (M));
 142
 143    begin
 144       if Prf = System.Null_Address then
 145          c_set_code_loc (M, 0);
 146       else
 147          exc_virtual_unwind (Prf, M);
 148       end if;
 149    end Pop_Frame;
 150
 151    -----------------------
 152    -- Set_Machine_State --
 153    -----------------------
 154
 155    procedure Set_Machine_State (M : Machine_State) is
 156       procedure c_capture_context (M : Machine_State);
 157       pragma Import (C, c_capture_context, "exc_capture_context");
 158    begin
 159       c_capture_context (M);
 160       Pop_Frame (M);
 161    end Set_Machine_State;
 162
 163 end System.Machine_State_Operations;