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