1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- SYSTEM.MACHINE_STATE_OPERATIONS --
8 -- (Version for Alpha/VMS) --
10 -- Copyright (C) 2001-2002 Ada Core Technologies, Inc. --
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, 51 Franklin Street, Fifth Floor, --
21 -- Boston, MA 02110-1301, USA. --
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. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- Extensive contributions were provided by Ada Core Technologies Inc. --
33 ------------------------------------------------------------------------------
35 -- This version of System.Machine_State_Operations is for use on
36 -- Alpha systems running VMS.
39 with System.Aux_DEC; use System.Aux_DEC;
40 with Unchecked_Conversion;
42 package body System.Machine_State_Operations is
44 use System.Exceptions;
45 subtype Cond_Value_Type is Unsigned_Longword;
47 -- Record layouts copied from Starlet.
49 type ICB_Fflags_Bits_Type is record
50 Exception_Frame : Boolean;
52 Bottom_Of_Stack : Boolean;
54 Filler_1 : Unsigned_20;
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;
64 for ICB_Fflags_Bits_Type'Size use 24;
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;
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;
77 for ICB_Hdr_Quad_Type'Size use 64;
79 type Invo_Context_Blk_Type is record
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)
87 Procedure_Descriptor : Unsigned_Quadword;
88 -- The address of the procedure descriptor for the procedure
90 Program_Counter : Integer_64;
91 -- The current PC of a given procedure invocation
93 Processor_Status : Integer_64;
94 -- The current PS of a given procedure invocation
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.
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.
104 -- Chfctx_Addr : Unsigned_Quadword;
105 -- Defined as a comment since it overlaps other fields
107 Filler_1 : String (1 .. 0);
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;
120 -- Component representation spec(s) below are defined as
121 -- comments since they overlap other fields
123 -- Chfctx_Addr at 528 range 0 .. 63;
125 Filler_1 at 544 range 0 .. -1;
127 for Invo_Context_Blk_Type'Size use 4352;
129 subtype Invo_Handle_Type is Unsigned_Longword;
131 type Invo_Handle_Access_Type is access all Invo_Handle_Type;
133 function Fetch is new Fetch_From_Address (Code_Loc);
135 function To_Invo_Handle_Access is new Unchecked_Conversion
136 (Machine_State, Invo_Handle_Access_Type);
138 function To_Machine_State is new Unchecked_Conversion
139 (System.Address, Machine_State);
141 ----------------------------
142 -- Allocate_Machine_State --
143 ----------------------------
145 function Allocate_Machine_State return Machine_State is
147 return To_Machine_State
148 (Memory.Alloc (Invo_Handle_Type'Max_Size_In_Storage_Elements));
149 end Allocate_Machine_State;
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);
161 pragma Interface (External, Get_Invo_Context);
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));
167 ICB : Invo_Context_Blk_Type;
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);
176 pragma Interface (External, Goto_Unwind);
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));
185 Status : Cond_Value_Type;
188 Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB);
190 (Status, System.Address (To_Invo_Handle_Access (M).all), Handler);
197 function Fetch_Code (Loc : Code_Loc) return Code_Loc is
199 -- The starting address is in the second longword pointed to by Loc.
201 return Fetch (System.Aux_DEC."+" (Loc, 8));
204 ------------------------
205 -- Free_Machine_State --
206 ------------------------
208 procedure Free_Machine_State (M : in out Machine_State) is
210 Memory.Free (Address (M));
211 M := Machine_State (Null_Address);
212 end Free_Machine_State;
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);
224 pragma Interface (External, Get_Invo_Context);
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));
230 Asm_Call_Size : constant := 4;
232 -- asm instruction takes 4 bytes. So we must remove this amount.
234 ICB : Invo_Context_Blk_Type;
235 Status : Cond_Value_Type;
238 Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB);
240 if (Status and 1) /= 1 then
241 return Code_Loc (System.Null_Address);
244 return Code_Loc (ICB.Program_Counter - Asm_Call_Size);
247 --------------------------
248 -- Machine_State_Length --
249 --------------------------
251 function Machine_State_Length
252 return System.Storage_Elements.Storage_Offset
254 use System.Storage_Elements;
257 return Invo_Handle_Type'Size / 8;
258 end Machine_State_Length;
266 Info : Subprogram_Info_Type)
268 pragma Warnings (Off, Info);
270 procedure Get_Prev_Invo_Handle (
271 Result : out Invo_Handle_Type; -- return value
272 ICB : in Invo_Handle_Type);
274 pragma Interface (External, Get_Prev_Invo_Handle);
276 pragma Import_Valued_Procedure
277 (Get_Prev_Invo_Handle, "LIB$GET_PREV_INVO_HANDLE",
278 (Invo_Handle_Type, Invo_Handle_Type),
281 Prev_Handle : aliased Invo_Handle_Type;
284 Get_Prev_Invo_Handle (Prev_Handle, To_Invo_Handle_Access (M).all);
285 To_Invo_Handle_Access (M).all := Prev_Handle;
288 -----------------------
289 -- Set_Machine_State --
290 -----------------------
292 procedure Set_Machine_State (M : Machine_State) is
294 procedure Get_Curr_Invo_Context
295 (Invo_Context : out Invo_Context_Blk_Type);
297 pragma Interface (External, Get_Curr_Invo_Context);
299 pragma Import_Valued_Procedure
300 (Get_Curr_Invo_Context, "LIB$GET_CURR_INVO_CONTEXT",
301 (Invo_Context_Blk_Type),
304 procedure Get_Invo_Handle (
305 Result : out Invo_Handle_Type; -- return value
306 Invo_Context : in Invo_Context_Blk_Type);
308 pragma Interface (External, Get_Invo_Handle);
310 pragma Import_Valued_Procedure (Get_Invo_Handle, "LIB$GET_INVO_HANDLE",
311 (Invo_Handle_Type, Invo_Context_Blk_Type),
314 ICB : Invo_Context_Blk_Type;
315 Invo_Handle : aliased Invo_Handle_Type;
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;
324 ------------------------------
325 -- Set_Signal_Machine_State --
326 ------------------------------
328 procedure Set_Signal_Machine_State
330 Context : System.Address)
332 pragma Warnings (Off, M);
333 pragma Warnings (Off, Context);
337 end Set_Signal_Machine_State;
339 end System.Machine_State_Operations;