gcc/ada/5vmastop.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 --                            $Revision: 1.3 $
  11 --                                                                          --
  12 --              Copyright (C) 2001 Ada Core Technologies, Inc.              --
  13 --                                                                          --
  14 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  15 -- terms of the  GNU General Public License as published  by the Free Soft- --
  16 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  17 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  18 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  19 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  20 -- for  more details.  You should have  received  a copy of the GNU General --
  21 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  22 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  23 -- MA 02111-1307, USA.                                                      --
  24 --                                                                          --
  25 -- As a special exception,  if other files  instantiate  generics from this --
  26 -- unit, or you link  this unit with other files  to produce an executable, --
  27 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  28 -- covered  by the  GNU  General  Public  License.  This exception does not --
  29 -- however invalidate  any other reasons why  the executable file  might be --
  30 -- covered by the  GNU Public License.                                      --
  31 --                                                                          --
  32 -- GNAT was originally developed  by the GNAT team at  New York University. --
  33 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  34 --                                                                          --
  35 ------------------------------------------------------------------------------
  36
  37 --  This version of System.Machine_State_Operations is for use on
  38 --  Alpha systems running VMS.
  39
  40 with System.Memory;
  41 with System.Aux_DEC; use System.Aux_DEC;
  42 with Unchecked_Conversion;
  43
  44 package body System.Machine_State_Operations is
  45
  46    use System.Exceptions;
  47    subtype Cond_Value_Type is Unsigned_Longword;
  48
  49    --  Record layouts copied from Starlet.
  50
  51    type ICB_Fflags_Bits_Type is record
  52       Exception_Frame : Boolean;
  53       Ast_Frame       : Boolean;
  54       Bottom_Of_Stack : Boolean;
  55       Base_Frame      : Boolean;
  56       Filler_1        : Unsigned_20;
  57    end record;
  58
  59    for ICB_Fflags_Bits_Type use record
  60       Exception_Frame at 0 range 0 .. 0;
  61       Ast_Frame       at 0 range 1 .. 1;
  62       Bottom_Of_Stack at 0 range 2 .. 2;
  63       Base_Frame      at 0 range 3 .. 3;
  64       Filler_1        at 0 range 4 .. 23;
  65    end record;
  66    for ICB_Fflags_Bits_Type'Size use 24;
  67
  68    ICB_Fflags_Bits_Type_Init : constant ICB_Fflags_Bits_Type :=
  69      (ExceptIon_Frame    => False,
  70       Ast_Frame          => False,
  71       Bottom_Of_STACK    => False,
  72       Base_Frame         => False,
  73       Filler_1           => 0);
  74
  75    type ICB_Hdr_Quad_Type is record
  76       Context_Length : Unsigned_Longword;
  77       Fflags_Bits    : ICB_Fflags_Bits_Type;
  78       Block_Version  : Unsigned_Byte;
  79    end record;
  80
  81    for ICB_Hdr_Quad_Type use record
  82       Context_Length at 0 range 0 .. 31;
  83       Fflags_Bits    at 4 range 0 .. 23;
  84       Block_Version  at 7 range 0 .. 7;
  85    end record;
  86    for ICB_Hdr_Quad_Type'Size use 64;
  87
  88    ICB_Hdr_Quad_Type_Init : constant ICB_Hdr_Quad_Type :=
  89      (Context_Length => 0,
  90       Fflags_Bits    => ICB_Fflags_Bits_Type_Init,
  91       Block_Version  => 0);
  92
  93    type Invo_Context_Blk_Type is record
  94       --
  95       --  The first quadword contains:
  96       --      o  The length of the structure in bytes (a longword field)
  97       --      o  The frame flags (a 3 byte field of bits)
  98       --      o  The version number (a 1 byte field)
  99       --
 100       Hdr_Quad             : ICB_Hdr_Quad_Type;
 101       --
 102       --  The address of the procedure descriptor for the procedure.
 103       --
 104       Procedure_Descriptor : Unsigned_Quadword;
 105       --
 106       --  The current PC of a given procedure invocation.
 107       --
 108       Program_Counter      : Integer_64;
 109       --
 110       --  The current PS of a given procedure invocation.
 111       --
 112       Processor_Status     : Integer_64;
 113       --
 114       --  The register contents areas. 31 for scalars, 31 for float.
 115       --
 116       Ireg                 : Unsigned_Quadword_Array (0 .. 30);
 117       Freg                 : Unsigned_Quadword_Array (0 .. 30);
 118       --
 119       --  The following is an "internal" area that's reserved for use by
 120       --  the operating system. It's size may vary over time.
 121       --
 122       System_Defined       : Unsigned_Quadword_Array (0 .. 1);
 123
 124       ----Component(s) below are defined as comments since they
 125       ----overlap other fields
 126       ----
 127       ----Chfctx_Addr      : Unsigned_Quadword;
 128
 129       --
 130       --  Align to octaword.
 131       --
 132       Filler_1             : String (1 .. 0);
 133    end record;
 134
 135    for Invo_Context_Blk_Type use record
 136       Hdr_Quad             at   0 range 0 .. 63;
 137       Procedure_Descriptor at   8 range 0 .. 63;
 138       Program_Counter      at  16 range 0 .. 63;
 139       Processor_Status     at  24 range 0 .. 63;
 140       Ireg                 at  32 range 0 .. 1983;
 141       Freg                 at 280 range 0 .. 1983;
 142       System_Defined       at 528 range 0 .. 127;
 143
 144       ----Component representation spec(s) below are defined as
 145       ----comments since they overlap other fields
 146       ----
 147       ----Chfctx_Addr at 528 range 0 .. 63;
 148
 149       Filler_1 at 544 range 0 .. -1;
 150    end record;
 151    for Invo_Context_Blk_Type'Size use 4352;
 152
 153    Invo_Context_Blk_Type_Init : constant Invo_Context_Blk_Type :=
 154      (Hdr_Quad             => ICB_Hdr_Quad_Type_Init,
 155       Procedure_Descriptor => (0, 0),
 156       Program_Counter      => 0,
 157       Processor_Status     => 0,
 158       Ireg                 => (others => (0, 0)),
 159       Freg                 => (others => (0, 0)),
 160       System_Defined       => (others => (0, 0)),
 161       Filler_1             => (others => ASCII.NUL));
 162
 163    subtype Invo_Handle_Type is Unsigned_Longword;
 164
 165    type Invo_Handle_Access_Type is access all Invo_Handle_Type;
 166
 167    function Fetch is new Fetch_From_Address (Code_Loc);
 168
 169    function To_Invo_Handle_Access is new Unchecked_Conversion
 170      (Machine_State, Invo_Handle_Access_Type);
 171
 172    function To_Machine_State is new Unchecked_Conversion
 173      (System.Address, Machine_State);
 174
 175    function To_Code_Loc is new Unchecked_Conversion
 176      (Unsigned_Longword, Code_Loc);
 177
 178    ----------------------------
 179    -- Allocate_Machine_State --
 180    ----------------------------
 181
 182    function Allocate_Machine_State return Machine_State is
 183    begin
 184       return To_Machine_State
 185         (Memory.Alloc (Invo_Handle_Type'Max_Size_In_Storage_Elements));
 186    end Allocate_Machine_State;
 187
 188    -------------------
 189    -- Enter_Handler --
 190    -------------------
 191
 192    procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
 193       procedure Get_Invo_Context (
 194          Result       : out Unsigned_Longword; -- return value
 195          Invo_Handle  : in  Invo_Handle_Type;
 196          Invo_Context : out Invo_Context_Blk_Type);
 197
 198       pragma Interface (External, Get_Invo_Context);
 199
 200       pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT",
 201          (Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type),
 202          (Value, Value, Reference));
 203
 204       ICB : Invo_Context_Blk_Type;
 205
 206       procedure Goto_Unwind (
 207          Status      : out Cond_Value_Type; -- return value
 208          Target_Invo : in  Address := Address_Zero;
 209          Target_PC   : in  Address := Address_Zero;
 210          New_R0      : in  Unsigned_Quadword
 211           := Unsigned_Quadword'Null_Parameter;
 212          New_R1      : in  Unsigned_Quadword
 213           := Unsigned_Quadword'Null_Parameter);
 214
 215       pragma Interface (External, Goto_Unwind);
 216
 217       pragma Import_Valued_Procedure
 218         (Goto_Unwind, "SYS$GOTO_UNWIND",
 219          (Cond_Value_Type, Address, Address,
 220           Unsigned_Quadword, Unsigned_Quadword),
 221          (Value, Reference, Reference,
 222           Reference, Reference));
 223
 224       Status   : Cond_Value_Type;
 225
 226    begin
 227       Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB);
 228       Goto_Unwind
 229         (Status, System.Address (To_Invo_Handle_Access (M).all), Handler);
 230    end Enter_Handler;
 231
 232    ----------------
 233    -- Fetch_Code --
 234    ----------------
 235
 236    function Fetch_Code (Loc : Code_Loc) return Code_Loc is
 237    begin
 238       --  The starting address is in the second longword pointed to by Loc.
 239       return Fetch (System.Aux_DEC."+" (Loc, 8));
 240    end Fetch_Code;
 241
 242    ------------------------
 243    -- Free_Machine_State --
 244    ------------------------
 245
 246    procedure Free_Machine_State (M : in out Machine_State) is
 247       procedure Gnat_Free (M : in Invo_Handle_Access_Type);
 248       pragma Import (C, Gnat_Free, "__gnat_free");
 249
 250    begin
 251       Gnat_Free (To_Invo_Handle_Access (M));
 252       M := Machine_State (Null_Address);
 253    end Free_Machine_State;
 254
 255    ------------------
 256    -- Get_Code_Loc --
 257    ------------------
 258
 259    function Get_Code_Loc (M : Machine_State) return Code_Loc is
 260       procedure Get_Invo_Context (
 261          Result       : out Unsigned_Longword; -- return value
 262          Invo_Handle  : in  Invo_Handle_Type;
 263          Invo_Context : out Invo_Context_Blk_Type);
 264
 265       pragma Interface (External, Get_Invo_Context);
 266
 267       pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT",
 268          (Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type),
 269          (Value, Value, Reference));
 270
 271       Asm_Call_Size : constant := 4;
 272       --  Under VMS a call
 273       --  asm instruction takes 4 bytes. So we must remove this amount.
 274
 275       ICB : Invo_Context_Blk_Type;
 276       Status : Cond_Value_Type;
 277
 278    begin
 279       Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB);
 280       if (Status and 1) /= 1 then
 281          return Code_Loc (System.Null_Address);
 282       end if;
 283       return Code_Loc (ICB.Program_Counter - Asm_Call_Size);
 284    end Get_Code_Loc;
 285
 286    --------------------------
 287    -- Machine_State_Length --
 288    --------------------------
 289
 290    function Machine_State_Length
 291      return System.Storage_Elements.Storage_Offset
 292    is
 293       use System.Storage_Elements;
 294
 295    begin
 296       return Invo_Handle_Type'Size / 8;
 297    end Machine_State_Length;
 298
 299    ---------------
 300    -- Pop_Frame --
 301    ---------------
 302
 303    procedure Pop_Frame
 304      (M    : Machine_State;
 305       Info : Subprogram_Info_Type)
 306    is
 307
 308       procedure Get_Prev_Invo_Handle (
 309          Result : out Invo_Handle_Type; -- return value
 310          ICB    : in  Invo_Handle_Type);
 311
 312       pragma Interface (External, Get_Prev_Invo_Handle);
 313
 314       pragma Import_Valued_Procedure
 315         (Get_Prev_Invo_Handle, "LIB$GET_PREV_INVO_HANDLE",
 316          (Invo_Handle_Type, Invo_Handle_Type),
 317          (Value, Value));
 318
 319       Prev_Handle : aliased Invo_Handle_Type;
 320
 321    begin
 322       Get_Prev_Invo_Handle (Prev_Handle, To_Invo_Handle_Access (M).all);
 323       To_Invo_Handle_Access (M).all := Prev_Handle;
 324    end Pop_Frame;
 325
 326    -----------------------
 327    -- Set_Machine_State --
 328    -----------------------
 329
 330    procedure Set_Machine_State (M : Machine_State) is
 331
 332       procedure Get_Curr_Invo_Context
 333         (Invo_Context : out Invo_Context_Blk_Type);
 334
 335       pragma Interface (External, Get_Curr_Invo_Context);
 336
 337       pragma Import_Valued_Procedure
 338         (Get_Curr_Invo_Context, "LIB$GET_CURR_INVO_CONTEXT",
 339          (Invo_Context_Blk_Type),
 340          (Reference));
 341
 342       procedure Get_Invo_Handle (
 343          Result       : out Invo_Handle_Type; -- return value
 344          Invo_Context : in Invo_Context_Blk_Type);
 345
 346       pragma Interface (External, Get_Invo_Handle);
 347
 348       pragma Import_Valued_Procedure (Get_Invo_Handle, "LIB$GET_INVO_HANDLE",
 349          (Invo_Handle_Type, Invo_Context_Blk_Type),
 350          (Value, Reference));
 351
 352       ICB : Invo_Context_Blk_Type;
 353       Invo_Handle : aliased Invo_Handle_Type;
 354
 355    begin
 356       Get_Curr_Invo_Context (ICB);
 357       Get_Invo_Handle (Invo_Handle, ICB);
 358       To_Invo_Handle_Access (M).all := Invo_Handle;
 359       Pop_Frame (M, System.Null_Address);
 360    end Set_Machine_State;
 361
 362    ------------------------------
 363    -- Set_Signal_Machine_State --
 364    ------------------------------
 365
 366    procedure Set_Signal_Machine_State
 367      (M       : Machine_State;
 368       Context : System.Address) is
 369    begin
 370       null;
 371    end Set_Signal_Machine_State;
 372
 373 end System.Machine_State_Operations;