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