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 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
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 -- 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)
86 Hdr_Quad
: ICB_Hdr_Quad_Type
;
88 -- The address of the procedure descriptor for the procedure.
90 Procedure_Descriptor
: Unsigned_Quadword
;
92 -- The current PC of a given procedure invocation.
94 Program_Counter
: Integer_64
;
96 -- The current PS of a given procedure invocation.
98 Processor_Status
: Integer_64
;
100 -- The register contents areas. 31 for scalars, 31 for float.
102 Ireg
: Unsigned_Quadword_Array
(0 .. 30);
103 Freg
: Unsigned_Quadword_Array
(0 .. 30);
105 -- The following is an "internal" area that's reserved for use by
106 -- the operating system. It's size may vary over time.
108 System_Defined
: Unsigned_Quadword_Array
(0 .. 1);
110 ----Component(s) below are defined as comments since they
111 ----overlap other fields
113 ----Chfctx_Addr : Unsigned_Quadword;
116 -- Align to octaword.
118 Filler_1
: String (1 .. 0);
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;
130 ----Component representation spec(s) below are defined as
131 ----comments since they overlap other fields
133 ----Chfctx_Addr at 528 range 0 .. 63;
135 Filler_1
at 544 range 0 .. -1;
137 for Invo_Context_Blk_Type
'Size use 4352;
139 subtype Invo_Handle_Type
is Unsigned_Longword
;
141 type Invo_Handle_Access_Type
is access all Invo_Handle_Type
;
143 function Fetch
is new Fetch_From_Address
(Code_Loc
);
145 function To_Invo_Handle_Access
is new Unchecked_Conversion
146 (Machine_State
, Invo_Handle_Access_Type
);
148 function To_Machine_State
is new Unchecked_Conversion
149 (System
.Address
, Machine_State
);
151 ----------------------------
152 -- Allocate_Machine_State --
153 ----------------------------
155 function Allocate_Machine_State
return Machine_State
is
157 return To_Machine_State
158 (Memory
.Alloc
(Invo_Handle_Type
'Max_Size_In_Storage_Elements));
159 end Allocate_Machine_State
;
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
);
171 pragma Interface
(External
, Get_Invo_Context
);
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
));
177 ICB
: Invo_Context_Blk_Type
;
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);
188 pragma Interface
(External
, Goto_Unwind
);
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
));
197 Status
: Cond_Value_Type
;
200 Get_Invo_Context
(Status
, To_Invo_Handle_Access
(M
).all, ICB
);
202 (Status
, System
.Address
(To_Invo_Handle_Access
(M
).all), Handler
);
209 function Fetch_Code
(Loc
: Code_Loc
) return Code_Loc
is
211 -- The starting address is in the second longword pointed to by Loc.
212 return Fetch
(System
.Aux_DEC
."+" (Loc
, 8));
215 ------------------------
216 -- Free_Machine_State --
217 ------------------------
219 procedure Free_Machine_State
(M
: in out Machine_State
) is
221 Memory
.Free
(Address
(M
));
222 M
:= Machine_State
(Null_Address
);
223 end Free_Machine_State
;
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
);
235 pragma Interface
(External
, Get_Invo_Context
);
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
));
241 Asm_Call_Size
: constant := 4;
243 -- asm instruction takes 4 bytes. So we must remove this amount.
245 ICB
: Invo_Context_Blk_Type
;
246 Status
: Cond_Value_Type
;
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
);
253 return Code_Loc
(ICB
.Program_Counter
- Asm_Call_Size
);
256 --------------------------
257 -- Machine_State_Length --
258 --------------------------
260 function Machine_State_Length
261 return System
.Storage_Elements
.Storage_Offset
263 use System
.Storage_Elements
;
266 return Invo_Handle_Type
'Size / 8;
267 end Machine_State_Length
;
275 Info
: Subprogram_Info_Type
)
278 procedure Get_Prev_Invo_Handle
(
279 Result
: out Invo_Handle_Type
; -- return value
280 ICB
: in Invo_Handle_Type
);
282 pragma Interface
(External
, Get_Prev_Invo_Handle
);
284 pragma Import_Valued_Procedure
285 (Get_Prev_Invo_Handle
, "LIB$GET_PREV_INVO_HANDLE",
286 (Invo_Handle_Type
, Invo_Handle_Type
),
289 Prev_Handle
: aliased Invo_Handle_Type
;
292 Get_Prev_Invo_Handle
(Prev_Handle
, To_Invo_Handle_Access
(M
).all);
293 To_Invo_Handle_Access
(M
).all := Prev_Handle
;
296 -----------------------
297 -- Set_Machine_State --
298 -----------------------
300 procedure Set_Machine_State
(M
: Machine_State
) is
302 procedure Get_Curr_Invo_Context
303 (Invo_Context
: out Invo_Context_Blk_Type
);
305 pragma Interface
(External
, Get_Curr_Invo_Context
);
307 pragma Import_Valued_Procedure
308 (Get_Curr_Invo_Context
, "LIB$GET_CURR_INVO_CONTEXT",
309 (Invo_Context_Blk_Type
),
312 procedure Get_Invo_Handle
(
313 Result
: out Invo_Handle_Type
; -- return value
314 Invo_Context
: in Invo_Context_Blk_Type
);
316 pragma Interface
(External
, Get_Invo_Handle
);
318 pragma Import_Valued_Procedure
(Get_Invo_Handle
, "LIB$GET_INVO_HANDLE",
319 (Invo_Handle_Type
, Invo_Context_Blk_Type
),
322 ICB
: Invo_Context_Blk_Type
;
323 Invo_Handle
: aliased Invo_Handle_Type
;
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
;
332 ------------------------------
333 -- Set_Signal_Machine_State --
334 ------------------------------
336 procedure Set_Signal_Machine_State
338 Context
: System
.Address
) is
341 end Set_Signal_Machine_State
;
343 end System
.Machine_State_Operations
;