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, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, 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
;