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-2002 Ada Core Technologies, Inc.             --
  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,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, 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 Unchecked_Conversion;
  41
  42 package body System.Machine_State_Operations is
  43
  44    use System.Exceptions;
  45    subtype Cond_Value_Type is Unsigned_Longword;
  46
  47    --  Record layouts copied from Starlet.
  48
  49    type ICB_Fflags_Bits_Type is record
  50       Exception_Frame : Boolean;
  51       Ast_Frame       : Boolean;
  52       Bottom_Of_Stack : Boolean;
  53       Base_Frame      : Boolean;
  54       Filler_1        : Unsigned_20;
  55    end record;
  56
  57    for ICB_Fflags_Bits_Type use record
  58       Exception_Frame at 0 range 0 .. 0;
  59       Ast_Frame       at 0 range 1 .. 1;
  60       Bottom_Of_Stack at 0 range 2 .. 2;
  61       Base_Frame      at 0 range 3 .. 3;
  62       Filler_1        at 0 range 4 .. 23;
  63    end record;
  64    for ICB_Fflags_Bits_Type'Size use 24;
  65
  66    type ICB_Hdr_Quad_Type is record
  67       Context_Length : Unsigned_Longword;
  68       Fflags_Bits    : ICB_Fflags_Bits_Type;
  69       Block_Version  : Unsigned_Byte;
  70    end record;
  71
  72    for ICB_Hdr_Quad_Type use record
  73       Context_Length at 0 range 0 .. 31;
  74       Fflags_Bits    at 4 range 0 .. 23;
  75       Block_Version  at 7 range 0 .. 7;
  76    end record;
  77    for ICB_Hdr_Quad_Type'Size use 64;
  78
  79    type Invo_Context_Blk_Type is record
  80
  81       Hdr_Quad : ICB_Hdr_Quad_Type;
  82       --  The first quadword contains:
  83       --    o  The length of the structure in bytes (a longword field)
  84       --    o  The frame flags (a 3 byte field of bits)
  85       --    o  The version number (a 1 byte field)
  86
  87       Procedure_Descriptor : Unsigned_Quadword;
  88       --  The address of the procedure descriptor for the procedure
  89
  90       Program_Counter : Integer_64;
  91       --  The current PC of a given procedure invocation
  92
  93       Processor_Status : Integer_64;
  94       --  The current PS of a given procedure invocation
  95
  96       Ireg : Unsigned_Quadword_Array (0 .. 30);
  97       Freg : Unsigned_Quadword_Array (0 .. 30);
  98       --  The register contents areas. 31 for scalars, 31 for float.
  99
 100       System_Defined : Unsigned_Quadword_Array (0 .. 1);
 101       --  The following is an "internal" area that's reserved for use by
 102       --  the operating system. It's size may vary over time.
 103
 104       --  Chfctx_Addr : Unsigned_Quadword;
 105       --  Defined as a comment since it overlaps other fields
 106
 107       Filler_1             : String (1 .. 0);
 108       --  Align to octaword
 109    end record;
 110
 111    for Invo_Context_Blk_Type use record
 112       Hdr_Quad             at   0 range 0 .. 63;
 113       Procedure_Descriptor at   8 range 0 .. 63;
 114       Program_Counter      at  16 range 0 .. 63;
 115       Processor_Status     at  24 range 0 .. 63;
 116       Ireg                 at  32 range 0 .. 1983;
 117       Freg                 at 280 range 0 .. 1983;
 118       System_Defined       at 528 range 0 .. 127;
 119
 120       --  Component representation spec(s) below are defined as
 121       --  comments since they overlap other fields
 122
 123       --  Chfctx_Addr at 528 range 0 .. 63;
 124
 125       Filler_1 at 544 range 0 .. -1;
 126    end record;
 127    for Invo_Context_Blk_Type'Size use 4352;
 128
 129    subtype Invo_Handle_Type is Unsigned_Longword;
 130
 131    type Invo_Handle_Access_Type is access all Invo_Handle_Type;
 132
 133    function Fetch is new Fetch_From_Address (Code_Loc);
 134
 135    function To_Invo_Handle_Access is new Unchecked_Conversion
 136      (Machine_State, Invo_Handle_Access_Type);
 137
 138    function To_Machine_State is new Unchecked_Conversion
 139      (System.Address, Machine_State);
 140
 141    ----------------------------
 142    -- Allocate_Machine_State --
 143    ----------------------------
 144
 145    function Allocate_Machine_State return Machine_State is
 146    begin
 147       return To_Machine_State
 148         (Memory.Alloc (Invo_Handle_Type'Max_Size_In_Storage_Elements));
 149    end Allocate_Machine_State;
 150
 151    -------------------
 152    -- Enter_Handler --
 153    -------------------
 154
 155    procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
 156       procedure Get_Invo_Context (
 157          Result       : out Unsigned_Longword; -- return value
 158          Invo_Handle  : Invo_Handle_Type;
 159          Invo_Context : out Invo_Context_Blk_Type);
 160
 161       pragma Interface (External, Get_Invo_Context);
 162
 163       pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT",
 164          (Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type),
 165          (Value, Value, Reference));
 166
 167       ICB : Invo_Context_Blk_Type;
 168
 169       procedure Goto_Unwind (
 170          Status      : out Cond_Value_Type; -- return value
 171          Target_Invo : Address := Address_Zero;
 172          Target_PC   : Address := Address_Zero;
 173          New_R0      : Unsigned_Quadword := Unsigned_Quadword'Null_Parameter;
 174          New_R1      : Unsigned_Quadword := Unsigned_Quadword'Null_Parameter);
 175
 176       pragma Interface (External, Goto_Unwind);
 177
 178       pragma Import_Valued_Procedure
 179         (Goto_Unwind, "SYS$GOTO_UNWIND",
 180          (Cond_Value_Type, Address, Address,
 181           Unsigned_Quadword, Unsigned_Quadword),
 182          (Value, Reference, Reference,
 183           Reference, Reference));
 184
 185       Status : Cond_Value_Type;
 186
 187    begin
 188       Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB);
 189       Goto_Unwind
 190         (Status, System.Address (To_Invo_Handle_Access (M).all), Handler);
 191    end Enter_Handler;
 192
 193    ----------------
 194    -- Fetch_Code --
 195    ----------------
 196
 197    function Fetch_Code (Loc : Code_Loc) return Code_Loc is
 198    begin
 199       --  The starting address is in the second longword pointed to by Loc.
 200
 201       return Fetch (System.Aux_DEC."+" (Loc, 8));
 202    end Fetch_Code;
 203
 204    ------------------------
 205    -- Free_Machine_State --
 206    ------------------------
 207
 208    procedure Free_Machine_State (M : in out Machine_State) is
 209    begin
 210       Memory.Free (Address (M));
 211       M := Machine_State (Null_Address);
 212    end Free_Machine_State;
 213
 214    ------------------
 215    -- Get_Code_Loc --
 216    ------------------
 217
 218    function Get_Code_Loc (M : Machine_State) return Code_Loc is
 219       procedure Get_Invo_Context (
 220          Result       : out Unsigned_Longword; -- return value
 221          Invo_Handle  : in  Invo_Handle_Type;
 222          Invo_Context : out Invo_Context_Blk_Type);
 223
 224       pragma Interface (External, Get_Invo_Context);
 225
 226       pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT",
 227          (Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type),
 228          (Value, Value, Reference));
 229
 230       Asm_Call_Size : constant := 4;
 231       --  Under VMS a call
 232       --  asm instruction takes 4 bytes. So we must remove this amount.
 233
 234       ICB : Invo_Context_Blk_Type;
 235       Status : Cond_Value_Type;
 236
 237    begin
 238       Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB);
 239
 240       if (Status and 1) /= 1 then
 241          return Code_Loc (System.Null_Address);
 242       end if;
 243
 244       return Code_Loc (ICB.Program_Counter - Asm_Call_Size);
 245    end Get_Code_Loc;
 246
 247    --------------------------
 248    -- Machine_State_Length --
 249    --------------------------
 250
 251    function Machine_State_Length
 252      return System.Storage_Elements.Storage_Offset
 253    is
 254       use System.Storage_Elements;
 255
 256    begin
 257       return Invo_Handle_Type'Size / 8;
 258    end Machine_State_Length;
 259
 260    ---------------
 261    -- Pop_Frame --
 262    ---------------
 263
 264    procedure Pop_Frame
 265      (M    : Machine_State;
 266       Info : Subprogram_Info_Type)
 267    is
 268       pragma Warnings (Off, Info);
 269
 270       procedure Get_Prev_Invo_Handle (
 271          Result : out Invo_Handle_Type; -- return value
 272          ICB    : in  Invo_Handle_Type);
 273
 274       pragma Interface (External, Get_Prev_Invo_Handle);
 275
 276       pragma Import_Valued_Procedure
 277         (Get_Prev_Invo_Handle, "LIB$GET_PREV_INVO_HANDLE",
 278          (Invo_Handle_Type, Invo_Handle_Type),
 279          (Value, Value));
 280
 281       Prev_Handle : aliased Invo_Handle_Type;
 282
 283    begin
 284       Get_Prev_Invo_Handle (Prev_Handle, To_Invo_Handle_Access (M).all);
 285       To_Invo_Handle_Access (M).all := Prev_Handle;
 286    end Pop_Frame;
 287
 288    -----------------------
 289    -- Set_Machine_State --
 290    -----------------------
 291
 292    procedure Set_Machine_State (M : Machine_State) is
 293
 294       procedure Get_Curr_Invo_Context
 295         (Invo_Context : out Invo_Context_Blk_Type);
 296
 297       pragma Interface (External, Get_Curr_Invo_Context);
 298
 299       pragma Import_Valued_Procedure
 300         (Get_Curr_Invo_Context, "LIB$GET_CURR_INVO_CONTEXT",
 301          (Invo_Context_Blk_Type),
 302          (Reference));
 303
 304       procedure Get_Invo_Handle (
 305          Result       : out Invo_Handle_Type; -- return value
 306          Invo_Context : in Invo_Context_Blk_Type);
 307
 308       pragma Interface (External, Get_Invo_Handle);
 309
 310       pragma Import_Valued_Procedure (Get_Invo_Handle, "LIB$GET_INVO_HANDLE",
 311          (Invo_Handle_Type, Invo_Context_Blk_Type),
 312          (Value, Reference));
 313
 314       ICB : Invo_Context_Blk_Type;
 315       Invo_Handle : aliased Invo_Handle_Type;
 316
 317    begin
 318       Get_Curr_Invo_Context (ICB);
 319       Get_Invo_Handle (Invo_Handle, ICB);
 320       To_Invo_Handle_Access (M).all := Invo_Handle;
 321       Pop_Frame (M, System.Null_Address);
 322    end Set_Machine_State;
 323
 324    ------------------------------
 325    -- Set_Signal_Machine_State --
 326    ------------------------------
 327
 328    procedure Set_Signal_Machine_State
 329      (M       : Machine_State;
 330       Context : System.Address)
 331    is
 332       pragma Warnings (Off, M);
 333       pragma Warnings (Off, Context);
 334
 335    begin
 336       null;
 337    end Set_Signal_Machine_State;
 338
 339 end System.Machine_State_Operations;