gcc/ada/s-mastop-vms.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                     SYSTEM.MACHINE_STATE_OPERATIONS                      --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                         (Version for Alpha/VMS)                          --
   9 --                                                                          --
  10 --                     Copyright (C) 2001-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 VMS.
  35
  36 with System.Memory;
  37 with System.Aux_DEC; use System.Aux_DEC;
  38 with Ada.Unchecked_Conversion;
  39
  40 package body System.Machine_State_Operations is
  41
  42    subtype Cond_Value_Type is Unsigned_Longword;
  43
  44    --  Record layouts copied from Starlet
  45
  46    type ICB_Fflags_Bits_Type is record
  47       Exception_Frame : Boolean;
  48       Ast_Frame       : Boolean;
  49       Bottom_Of_Stack : Boolean;
  50       Base_Frame      : Boolean;
  51       Filler_1        : Unsigned_20;
  52    end record;
  53
  54    for ICB_Fflags_Bits_Type use record
  55       Exception_Frame at 0 range 0 .. 0;
  56       Ast_Frame       at 0 range 1 .. 1;
  57       Bottom_Of_Stack at 0 range 2 .. 2;
  58       Base_Frame      at 0 range 3 .. 3;
  59       Filler_1        at 0 range 4 .. 23;
  60    end record;
  61    for ICB_Fflags_Bits_Type'Size use 24;
  62
  63    type ICB_Hdr_Quad_Type is record
  64       Context_Length : Unsigned_Longword;
  65       Fflags_Bits    : ICB_Fflags_Bits_Type;
  66       Block_Version  : Unsigned_Byte;
  67    end record;
  68
  69    for ICB_Hdr_Quad_Type use record
  70       Context_Length at 0 range 0 .. 31;
  71       Fflags_Bits    at 4 range 0 .. 23;
  72       Block_Version  at 7 range 0 .. 7;
  73    end record;
  74    for ICB_Hdr_Quad_Type'Size use 64;
  75
  76    type Invo_Context_Blk_Type is record
  77
  78       Hdr_Quad : ICB_Hdr_Quad_Type;
  79       --  The first quadword contains:
  80       --    o  The length of the structure in bytes (a longword field)
  81       --    o  The frame flags (a 3 byte field of bits)
  82       --    o  The version number (a 1 byte field)
  83
  84       Procedure_Descriptor : Unsigned_Quadword;
  85       --  The address of the procedure descriptor for the procedure
  86
  87       Program_Counter : Integer_64;
  88       --  The current PC of a given procedure invocation
  89
  90       Processor_Status : Integer_64;
  91       --  The current PS of a given procedure invocation
  92
  93       Ireg : Unsigned_Quadword_Array (0 .. 30);
  94       Freg : Unsigned_Quadword_Array (0 .. 30);
  95       --  The register contents areas. 31 for scalars, 31 for float
  96
  97       System_Defined : Unsigned_Quadword_Array (0 .. 1);
  98       --  The following is an "internal" area that's reserved for use by
  99       --  the operating system. It's size may vary over time.
 100
 101       --  Chfctx_Addr : Unsigned_Quadword;
 102       --  Defined as a comment since it overlaps other fields
 103
 104       Filler_1             : String (1 .. 0);
 105       --  Align to octaword
 106    end record;
 107
 108    for Invo_Context_Blk_Type use record
 109       Hdr_Quad             at   0 range 0 .. 63;
 110       Procedure_Descriptor at   8 range 0 .. 63;
 111       Program_Counter      at  16 range 0 .. 63;
 112       Processor_Status     at  24 range 0 .. 63;
 113       Ireg                 at  32 range 0 .. 1983;
 114       Freg                 at 280 range 0 .. 1983;
 115       System_Defined       at 528 range 0 .. 127;
 116
 117       --  Component representation spec(s) below are defined as
 118       --  comments since they overlap other fields
 119
 120       --  Chfctx_Addr at 528 range 0 .. 63;
 121
 122       Filler_1 at 544 range 0 .. -1;
 123    end record;
 124    for Invo_Context_Blk_Type'Size use 4352;
 125
 126    subtype Invo_Handle_Type is Unsigned_Longword;
 127
 128    type Invo_Handle_Access_Type is access all Invo_Handle_Type;
 129
 130    function Fetch is new Fetch_From_Address (Code_Loc);
 131
 132    function To_Invo_Handle_Access is new Ada.Unchecked_Conversion
 133      (Machine_State, Invo_Handle_Access_Type);
 134
 135    function To_Machine_State is new Ada.Unchecked_Conversion
 136      (System.Address, Machine_State);
 137
 138    ----------------------------
 139    -- Allocate_Machine_State --
 140    ----------------------------
 141
 142    function Allocate_Machine_State return Machine_State is
 143    begin
 144       return To_Machine_State
 145         (Memory.Alloc (Invo_Handle_Type'Max_Size_In_Storage_Elements));
 146    end Allocate_Machine_State;
 147
 148    ----------------
 149    -- Fetch_Code --
 150    ----------------
 151
 152    function Fetch_Code (Loc : Code_Loc) return Code_Loc is
 153    begin
 154       --  The starting address is in the second longword pointed to by Loc
 155
 156       return Fetch (System.Aux_DEC."+" (Loc, 8));
 157    end Fetch_Code;
 158
 159    ------------------------
 160    -- Free_Machine_State --
 161    ------------------------
 162
 163    procedure Free_Machine_State (M : in out Machine_State) is
 164    begin
 165       Memory.Free (Address (M));
 166       M := Machine_State (Null_Address);
 167    end Free_Machine_State;
 168
 169    ------------------
 170    -- Get_Code_Loc --
 171    ------------------
 172
 173    function Get_Code_Loc (M : Machine_State) return Code_Loc is
 174       procedure Get_Invo_Context (
 175          Result       : out Unsigned_Longword; -- return value
 176          Invo_Handle  : Invo_Handle_Type;
 177          Invo_Context : out Invo_Context_Blk_Type);
 178
 179       pragma Interface (External, Get_Invo_Context);
 180
 181       pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT",
 182          (Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type),
 183          (Value, Value, Reference));
 184
 185       Asm_Call_Size : constant := 4;
 186       --  Under VMS a call
 187       --  asm instruction takes 4 bytes. So we must remove this amount.
 188
 189       ICB : Invo_Context_Blk_Type;
 190       Status : Cond_Value_Type;
 191
 192    begin
 193       Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB);
 194
 195       if (Status and 1) /= 1 then
 196          return Code_Loc (System.Null_Address);
 197       end if;
 198
 199       return Code_Loc (ICB.Program_Counter - Asm_Call_Size);
 200    end Get_Code_Loc;
 201
 202    --------------------------
 203    -- Machine_State_Length --
 204    --------------------------
 205
 206    function Machine_State_Length
 207      return System.Storage_Elements.Storage_Offset
 208    is
 209       use System.Storage_Elements;
 210
 211    begin
 212       return Invo_Handle_Type'Size / 8;
 213    end Machine_State_Length;
 214
 215    ---------------
 216    -- Pop_Frame --
 217    ---------------
 218
 219    procedure Pop_Frame (M : Machine_State) is
 220       procedure Get_Prev_Invo_Handle (
 221          Result : out Invo_Handle_Type; -- return value
 222          ICB    : Invo_Handle_Type);
 223
 224       pragma Interface (External, Get_Prev_Invo_Handle);
 225
 226       pragma Import_Valued_Procedure
 227         (Get_Prev_Invo_Handle, "LIB$GET_PREV_INVO_HANDLE",
 228          (Invo_Handle_Type, Invo_Handle_Type),
 229          (Value, Value));
 230
 231       Prev_Handle : aliased Invo_Handle_Type;
 232
 233    begin
 234       Get_Prev_Invo_Handle (Prev_Handle, To_Invo_Handle_Access (M).all);
 235       To_Invo_Handle_Access (M).all := Prev_Handle;
 236    end Pop_Frame;
 237
 238    -----------------------
 239    -- Set_Machine_State --
 240    -----------------------
 241
 242    procedure Set_Machine_State (M : Machine_State) is
 243
 244       procedure Get_Curr_Invo_Context
 245         (Invo_Context : out Invo_Context_Blk_Type);
 246
 247       pragma Interface (External, Get_Curr_Invo_Context);
 248
 249       pragma Import_Valued_Procedure
 250         (Get_Curr_Invo_Context, "LIB$GET_CURR_INVO_CONTEXT",
 251          (Invo_Context_Blk_Type),
 252          (Reference));
 253
 254       procedure Get_Invo_Handle (
 255          Result       : out Invo_Handle_Type; -- return value
 256          Invo_Context : Invo_Context_Blk_Type);
 257
 258       pragma Interface (External, Get_Invo_Handle);
 259
 260       pragma Import_Valued_Procedure (Get_Invo_Handle, "LIB$GET_INVO_HANDLE",
 261          (Invo_Handle_Type, Invo_Context_Blk_Type),
 262          (Value, Reference));
 263
 264       ICB         : Invo_Context_Blk_Type;
 265       Invo_Handle : aliased Invo_Handle_Type;
 266
 267    begin
 268       Get_Curr_Invo_Context (ICB);
 269       Get_Invo_Handle (Invo_Handle, ICB);
 270       To_Invo_Handle_Access (M).all := Invo_Handle;
 271       Pop_Frame (M, System.Null_Address);
 272    end Set_Machine_State;
 273
 274 end System.Machine_State_Operations;