1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- SYSTEM.MACHINE_STATE_OPERATIONS --
8 -- (Version for Alpha/VMS) --
11 -- Copyright (C) 2001-2002 Ada Core Technologies, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT was originally developed by the GNAT team at New York University. --
32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
34 ------------------------------------------------------------------------------
36 -- This version of System.Machine_State_Operations is for use on
37 -- Alpha systems running VMS.
40 with System
.Aux_DEC
; use System
.Aux_DEC
;
41 with Unchecked_Conversion
;
43 package body System
.Machine_State_Operations
is
45 use System
.Exceptions
;
46 subtype Cond_Value_Type
is Unsigned_Longword
;
48 -- Record layouts copied from Starlet.
50 type ICB_Fflags_Bits_Type
is record
51 Exception_Frame
: Boolean;
53 Bottom_Of_Stack
: Boolean;
55 Filler_1
: Unsigned_20
;
58 for ICB_Fflags_Bits_Type
use record
59 Exception_Frame
at 0 range 0 .. 0;
60 Ast_Frame
at 0 range 1 .. 1;
61 Bottom_Of_Stack
at 0 range 2 .. 2;
62 Base_Frame
at 0 range 3 .. 3;
63 Filler_1
at 0 range 4 .. 23;
65 for ICB_Fflags_Bits_Type
'Size use 24;
67 type ICB_Hdr_Quad_Type
is record
68 Context_Length
: Unsigned_Longword
;
69 Fflags_Bits
: ICB_Fflags_Bits_Type
;
70 Block_Version
: Unsigned_Byte
;
73 for ICB_Hdr_Quad_Type
use record
74 Context_Length
at 0 range 0 .. 31;
75 Fflags_Bits
at 4 range 0 .. 23;
76 Block_Version
at 7 range 0 .. 7;
78 for ICB_Hdr_Quad_Type
'Size use 64;
80 type Invo_Context_Blk_Type
is record
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 Hdr_Quad
: ICB_Hdr_Quad_Type
;
89 -- The address of the procedure descriptor for the procedure.
91 Procedure_Descriptor
: Unsigned_Quadword
;
93 -- The current PC of a given procedure invocation.
95 Program_Counter
: Integer_64
;
97 -- The current PS of a given procedure invocation.
99 Processor_Status
: Integer_64
;
101 -- The register contents areas. 31 for scalars, 31 for float.
103 Ireg
: Unsigned_Quadword_Array
(0 .. 30);
104 Freg
: Unsigned_Quadword_Array
(0 .. 30);
106 -- The following is an "internal" area that's reserved for use by
107 -- the operating system. It's size may vary over time.
109 System_Defined
: Unsigned_Quadword_Array
(0 .. 1);
111 ----Component(s) below are defined as comments since they
112 ----overlap other fields
114 ----Chfctx_Addr : Unsigned_Quadword;
117 -- Align to octaword.
119 Filler_1
: String (1 .. 0);
122 for Invo_Context_Blk_Type
use record
123 Hdr_Quad
at 0 range 0 .. 63;
124 Procedure_Descriptor
at 8 range 0 .. 63;
125 Program_Counter
at 16 range 0 .. 63;
126 Processor_Status
at 24 range 0 .. 63;
127 Ireg
at 32 range 0 .. 1983;
128 Freg
at 280 range 0 .. 1983;
129 System_Defined
at 528 range 0 .. 127;
131 ----Component representation spec(s) below are defined as
132 ----comments since they overlap other fields
134 ----Chfctx_Addr at 528 range 0 .. 63;
136 Filler_1
at 544 range 0 .. -1;
138 for Invo_Context_Blk_Type
'Size use 4352;
140 subtype Invo_Handle_Type
is Unsigned_Longword
;
142 type Invo_Handle_Access_Type
is access all Invo_Handle_Type
;
144 function Fetch
is new Fetch_From_Address
(Code_Loc
);
146 function To_Invo_Handle_Access
is new Unchecked_Conversion
147 (Machine_State
, Invo_Handle_Access_Type
);
149 function To_Machine_State
is new Unchecked_Conversion
150 (System
.Address
, Machine_State
);
152 ----------------------------
153 -- Allocate_Machine_State --
154 ----------------------------
156 function Allocate_Machine_State
return Machine_State
is
158 return To_Machine_State
159 (Memory
.Alloc
(Invo_Handle_Type
'Max_Size_In_Storage_Elements));
160 end Allocate_Machine_State
;
166 procedure Enter_Handler
(M
: Machine_State
; Handler
: Handler_Loc
) is
167 procedure Get_Invo_Context
(
168 Result
: out Unsigned_Longword
; -- return value
169 Invo_Handle
: in Invo_Handle_Type
;
170 Invo_Context
: out Invo_Context_Blk_Type
);
172 pragma Interface
(External
, Get_Invo_Context
);
174 pragma Import_Valued_Procedure
(Get_Invo_Context
, "LIB$GET_INVO_CONTEXT",
175 (Unsigned_Longword
, Invo_Handle_Type
, Invo_Context_Blk_Type
),
176 (Value
, Value
, Reference
));
178 ICB
: Invo_Context_Blk_Type
;
180 procedure Goto_Unwind
(
181 Status
: out Cond_Value_Type
; -- return value
182 Target_Invo
: in Address
:= Address_Zero
;
183 Target_PC
: in Address
:= Address_Zero
;
184 New_R0
: in Unsigned_Quadword
185 := Unsigned_Quadword
'Null_Parameter;
186 New_R1
: in Unsigned_Quadword
187 := Unsigned_Quadword
'Null_Parameter);
189 pragma Interface
(External
, Goto_Unwind
);
191 pragma Import_Valued_Procedure
192 (Goto_Unwind
, "SYS$GOTO_UNWIND",
193 (Cond_Value_Type
, Address
, Address
,
194 Unsigned_Quadword
, Unsigned_Quadword
),
195 (Value
, Reference
, Reference
,
196 Reference
, Reference
));
198 Status
: Cond_Value_Type
;
201 Get_Invo_Context
(Status
, To_Invo_Handle_Access
(M
).all, ICB
);
203 (Status
, System
.Address
(To_Invo_Handle_Access
(M
).all), Handler
);
210 function Fetch_Code
(Loc
: Code_Loc
) return Code_Loc
is
212 -- The starting address is in the second longword pointed to by Loc.
213 return Fetch
(System
.Aux_DEC
."+" (Loc
, 8));
216 ------------------------
217 -- Free_Machine_State --
218 ------------------------
220 procedure Free_Machine_State
(M
: in out Machine_State
) is
222 Memory
.Free
(Address
(M
));
223 M
:= Machine_State
(Null_Address
);
224 end Free_Machine_State
;
230 function Get_Code_Loc
(M
: Machine_State
) return Code_Loc
is
231 procedure Get_Invo_Context
(
232 Result
: out Unsigned_Longword
; -- return value
233 Invo_Handle
: in Invo_Handle_Type
;
234 Invo_Context
: out Invo_Context_Blk_Type
);
236 pragma Interface
(External
, Get_Invo_Context
);
238 pragma Import_Valued_Procedure
(Get_Invo_Context
, "LIB$GET_INVO_CONTEXT",
239 (Unsigned_Longword
, Invo_Handle_Type
, Invo_Context_Blk_Type
),
240 (Value
, Value
, Reference
));
242 Asm_Call_Size
: constant := 4;
244 -- asm instruction takes 4 bytes. So we must remove this amount.
246 ICB
: Invo_Context_Blk_Type
;
247 Status
: Cond_Value_Type
;
250 Get_Invo_Context
(Status
, To_Invo_Handle_Access
(M
).all, ICB
);
251 if (Status
and 1) /= 1 then
252 return Code_Loc
(System
.Null_Address
);
254 return Code_Loc
(ICB
.Program_Counter
- Asm_Call_Size
);
257 --------------------------
258 -- Machine_State_Length --
259 --------------------------
261 function Machine_State_Length
262 return System
.Storage_Elements
.Storage_Offset
264 use System
.Storage_Elements
;
267 return Invo_Handle_Type
'Size / 8;
268 end Machine_State_Length
;
276 Info
: Subprogram_Info_Type
)
279 procedure Get_Prev_Invo_Handle
(
280 Result
: out Invo_Handle_Type
; -- return value
281 ICB
: in Invo_Handle_Type
);
283 pragma Interface
(External
, Get_Prev_Invo_Handle
);
285 pragma Import_Valued_Procedure
286 (Get_Prev_Invo_Handle
, "LIB$GET_PREV_INVO_HANDLE",
287 (Invo_Handle_Type
, Invo_Handle_Type
),
290 Prev_Handle
: aliased Invo_Handle_Type
;
293 Get_Prev_Invo_Handle
(Prev_Handle
, To_Invo_Handle_Access
(M
).all);
294 To_Invo_Handle_Access
(M
).all := Prev_Handle
;
297 -----------------------
298 -- Set_Machine_State --
299 -----------------------
301 procedure Set_Machine_State
(M
: Machine_State
) is
303 procedure Get_Curr_Invo_Context
304 (Invo_Context
: out Invo_Context_Blk_Type
);
306 pragma Interface
(External
, Get_Curr_Invo_Context
);
308 pragma Import_Valued_Procedure
309 (Get_Curr_Invo_Context
, "LIB$GET_CURR_INVO_CONTEXT",
310 (Invo_Context_Blk_Type
),
313 procedure Get_Invo_Handle
(
314 Result
: out Invo_Handle_Type
; -- return value
315 Invo_Context
: in Invo_Context_Blk_Type
);
317 pragma Interface
(External
, Get_Invo_Handle
);
319 pragma Import_Valued_Procedure
(Get_Invo_Handle
, "LIB$GET_INVO_HANDLE",
320 (Invo_Handle_Type
, Invo_Context_Blk_Type
),
323 ICB
: Invo_Context_Blk_Type
;
324 Invo_Handle
: aliased Invo_Handle_Type
;
327 Get_Curr_Invo_Context
(ICB
);
328 Get_Invo_Handle
(Invo_Handle
, ICB
);
329 To_Invo_Handle_Access
(M
).all := Invo_Handle
;
330 Pop_Frame
(M
, System
.Null_Address
);
331 end Set_Machine_State
;
333 ------------------------------
334 -- Set_Signal_Machine_State --
335 ------------------------------
337 procedure Set_Signal_Machine_State
339 Context
: System
.Address
) is
342 end Set_Signal_Machine_State
;
344 end System
.Machine_State_Operations
;