1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- SYSTEM.MACHINE_STATE_OPERATIONS --
8 -- (Version for Alpha/VMS) --
10 -- Copyright (C) 2001-2012, AdaCore --
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. --
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. --
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/>. --
28 -- GNAT was originally developed by the GNAT team at New York University. --
29 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 ------------------------------------------------------------------------------
33 -- This version of System.Machine_State_Operations is for use on
34 -- Alpha systems running VMS.
37 with System
.Aux_DEC
; use System
.Aux_DEC
;
38 with Ada
.Unchecked_Conversion
;
40 package body System
.Machine_State_Operations
is
42 subtype Cond_Value_Type
is Unsigned_Longword
;
44 -- Record layouts copied from Starlet
46 type ICB_Fflags_Bits_Type
is record
47 Exception_Frame
: Boolean;
49 Bottom_Of_Stack
: Boolean;
51 Filler_1
: Unsigned_20
;
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;
61 for ICB_Fflags_Bits_Type
'Size use 24;
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
;
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;
74 for ICB_Hdr_Quad_Type
'Size use 64;
76 type Invo_Context_Blk_Type
is record
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)
84 Procedure_Descriptor
: Unsigned_Quadword
;
85 -- The address of the procedure descriptor for the procedure
87 Program_Counter
: Integer_64
;
88 -- The current PC of a given procedure invocation
90 Processor_Status
: Integer_64
;
91 -- The current PS of a given procedure invocation
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
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.
101 -- Chfctx_Addr : Unsigned_Quadword;
102 -- Defined as a comment since it overlaps other fields
104 Filler_1
: String (1 .. 0);
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;
117 -- Component representation spec(s) below are defined as
118 -- comments since they overlap other fields
120 -- Chfctx_Addr at 528 range 0 .. 63;
122 Filler_1
at 544 range 0 .. -1;
124 for Invo_Context_Blk_Type
'Size use 4352;
126 subtype Invo_Handle_Type
is Unsigned_Longword
;
128 type Invo_Handle_Access_Type
is access all Invo_Handle_Type
;
130 function Fetch
is new Fetch_From_Address
(Code_Loc
);
132 function To_Invo_Handle_Access
is new Ada
.Unchecked_Conversion
133 (Machine_State
, Invo_Handle_Access_Type
);
135 function To_Machine_State
is new Ada
.Unchecked_Conversion
136 (System
.Address
, Machine_State
);
138 ----------------------------
139 -- Allocate_Machine_State --
140 ----------------------------
142 function Allocate_Machine_State
return Machine_State
is
144 return To_Machine_State
145 (Memory
.Alloc
(Invo_Handle_Type
'Max_Size_In_Storage_Elements));
146 end Allocate_Machine_State
;
152 function Fetch_Code
(Loc
: Code_Loc
) return Code_Loc
is
154 -- The starting address is in the second longword pointed to by Loc
156 return Fetch
(System
.Aux_DEC
."+" (Loc
, 8));
159 ------------------------
160 -- Free_Machine_State --
161 ------------------------
163 procedure Free_Machine_State
(M
: in out Machine_State
) is
165 Memory
.Free
(Address
(M
));
166 M
:= Machine_State
(Null_Address
);
167 end Free_Machine_State
;
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
);
179 pragma Import
(External
, Get_Invo_Context
);
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
));
185 Asm_Call_Size
: constant := 4;
187 -- asm instruction takes 4 bytes. So we must remove this amount.
189 ICB
: Invo_Context_Blk_Type
;
190 Status
: Cond_Value_Type
;
193 Get_Invo_Context
(Status
, To_Invo_Handle_Access
(M
).all, ICB
);
195 if (Status
and 1) /= 1 then
196 return Code_Loc
(System
.Null_Address
);
199 return Code_Loc
(ICB
.Program_Counter
- Asm_Call_Size
);
202 --------------------------
203 -- Machine_State_Length --
204 --------------------------
206 function Machine_State_Length
207 return System
.Storage_Elements
.Storage_Offset
209 use System
.Storage_Elements
;
212 return Invo_Handle_Type
'Size / 8;
213 end Machine_State_Length
;
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
);
224 pragma Import
(External
, Get_Prev_Invo_Handle
);
226 pragma Import_Valued_Procedure
227 (Get_Prev_Invo_Handle
, "LIB$GET_PREV_INVO_HANDLE",
228 (Invo_Handle_Type
, Invo_Handle_Type
),
231 Prev_Handle
: aliased Invo_Handle_Type
;
234 Get_Prev_Invo_Handle
(Prev_Handle
, To_Invo_Handle_Access
(M
).all);
235 To_Invo_Handle_Access
(M
).all := Prev_Handle
;
238 -----------------------
239 -- Set_Machine_State --
240 -----------------------
242 procedure Set_Machine_State
(M
: Machine_State
) is
244 procedure Get_Curr_Invo_Context
245 (Invo_Context
: out Invo_Context_Blk_Type
);
247 pragma Import
(External
, Get_Curr_Invo_Context
);
249 pragma Import_Valued_Procedure
250 (Get_Curr_Invo_Context
, "LIB$GET_CURR_INVO_CONTEXT",
251 (Invo_Context_Blk_Type
),
254 procedure Get_Invo_Handle
(
255 Result
: out Invo_Handle_Type
; -- return value
256 Invo_Context
: Invo_Context_Blk_Type
);
258 pragma Import
(External
, Get_Invo_Handle
);
260 pragma Import_Valued_Procedure
(Get_Invo_Handle
, "LIB$GET_INVO_HANDLE",
261 (Invo_Handle_Type
, Invo_Context_Blk_Type
),
264 ICB
: Invo_Context_Blk_Type
;
265 Invo_Handle
: aliased Invo_Handle_Type
;
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
;
274 end System
.Machine_State_Operations
;