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