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