1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- SYSTEM.MACHINE_STATE_OPERATIONS -- 6-- -- 7-- B o d y -- 8-- (Version for Alpha/VMS) -- 9-- -- 10-- Copyright (C) 2001-2012, AdaCore -- 11-- -- 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. -- 18-- -- 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. -- 22-- -- 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/>. -- 27-- -- 28-- GNAT was originally developed by the GNAT team at New York University. -- 29-- Extensive contributions were provided by Ada Core Technologies Inc. -- 30-- -- 31------------------------------------------------------------------------------ 32 33-- This version of System.Machine_State_Operations is for use on 34-- Alpha systems running VMS. 35 36with System.Memory; 37with System.Aux_DEC; use System.Aux_DEC; 38with Ada.Unchecked_Conversion; 39 40package body System.Machine_State_Operations is 41 42 subtype Cond_Value_Type is Unsigned_Longword; 43 44 -- Record layouts copied from Starlet 45 46 type ICB_Fflags_Bits_Type is record 47 Exception_Frame : Boolean; 48 Ast_Frame : Boolean; 49 Bottom_Of_Stack : Boolean; 50 Base_Frame : Boolean; 51 Filler_1 : Unsigned_20; 52 end record; 53 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; 60 end record; 61 for ICB_Fflags_Bits_Type'Size use 24; 62 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; 67 end record; 68 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; 73 end record; 74 for ICB_Hdr_Quad_Type'Size use 64; 75 76 type Invo_Context_Blk_Type is record 77 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) 83 84 Procedure_Descriptor : Unsigned_Quadword; 85 -- The address of the procedure descriptor for the procedure 86 87 Program_Counter : Integer_64; 88 -- The current PC of a given procedure invocation 89 90 Processor_Status : Integer_64; 91 -- The current PS of a given procedure invocation 92 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 96 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. 100 101 -- Chfctx_Addr : Unsigned_Quadword; 102 -- Defined as a comment since it overlaps other fields 103 104 Filler_1 : String (1 .. 0); 105 -- Align to octaword 106 end record; 107 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; 116 117 -- Component representation spec(s) below are defined as 118 -- comments since they overlap other fields 119 120 -- Chfctx_Addr at 528 range 0 .. 63; 121 122 Filler_1 at 544 range 0 .. -1; 123 end record; 124 for Invo_Context_Blk_Type'Size use 4352; 125 126 subtype Invo_Handle_Type is Unsigned_Longword; 127 128 type Invo_Handle_Access_Type is access all Invo_Handle_Type; 129 130 function Fetch is new Fetch_From_Address (Code_Loc); 131 132 function To_Invo_Handle_Access is new Ada.Unchecked_Conversion 133 (Machine_State, Invo_Handle_Access_Type); 134 135 function To_Machine_State is new Ada.Unchecked_Conversion 136 (System.Address, Machine_State); 137 138 ---------------------------- 139 -- Allocate_Machine_State -- 140 ---------------------------- 141 142 function Allocate_Machine_State return Machine_State is 143 begin 144 return To_Machine_State 145 (Memory.Alloc (Invo_Handle_Type'Max_Size_In_Storage_Elements)); 146 end Allocate_Machine_State; 147 148 ---------------- 149 -- Fetch_Code -- 150 ---------------- 151 152 function Fetch_Code (Loc : Code_Loc) return Code_Loc is 153 begin 154 -- The starting address is in the second longword pointed to by Loc 155 156 return Fetch (System.Aux_DEC."+" (Loc, 8)); 157 end Fetch_Code; 158 159 ------------------------ 160 -- Free_Machine_State -- 161 ------------------------ 162 163 procedure Free_Machine_State (M : in out Machine_State) is 164 begin 165 Memory.Free (Address (M)); 166 M := Machine_State (Null_Address); 167 end Free_Machine_State; 168 169 ------------------ 170 -- Get_Code_Loc -- 171 ------------------ 172 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); 178 179 pragma Import (External, Get_Invo_Context); 180 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)); 184 185 Asm_Call_Size : constant := 4; 186 -- Under VMS a call 187 -- asm instruction takes 4 bytes. So we must remove this amount. 188 189 ICB : Invo_Context_Blk_Type; 190 Status : Cond_Value_Type; 191 192 begin 193 Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB); 194 195 if (Status and 1) /= 1 then 196 return Code_Loc (System.Null_Address); 197 end if; 198 199 return Code_Loc (ICB.Program_Counter - Asm_Call_Size); 200 end Get_Code_Loc; 201 202 -------------------------- 203 -- Machine_State_Length -- 204 -------------------------- 205 206 function Machine_State_Length 207 return System.Storage_Elements.Storage_Offset 208 is 209 use System.Storage_Elements; 210 211 begin 212 return Invo_Handle_Type'Size / 8; 213 end Machine_State_Length; 214 215 --------------- 216 -- Pop_Frame -- 217 --------------- 218 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); 223 224 pragma Import (External, Get_Prev_Invo_Handle); 225 226 pragma Import_Valued_Procedure 227 (Get_Prev_Invo_Handle, "LIB$GET_PREV_INVO_HANDLE", 228 (Invo_Handle_Type, Invo_Handle_Type), 229 (Value, Value)); 230 231 Prev_Handle : aliased Invo_Handle_Type; 232 233 begin 234 Get_Prev_Invo_Handle (Prev_Handle, To_Invo_Handle_Access (M).all); 235 To_Invo_Handle_Access (M).all := Prev_Handle; 236 end Pop_Frame; 237 238 ----------------------- 239 -- Set_Machine_State -- 240 ----------------------- 241 242 procedure Set_Machine_State (M : Machine_State) is 243 244 procedure Get_Curr_Invo_Context 245 (Invo_Context : out Invo_Context_Blk_Type); 246 247 pragma Import (External, Get_Curr_Invo_Context); 248 249 pragma Import_Valued_Procedure 250 (Get_Curr_Invo_Context, "LIB$GET_CURR_INVO_CONTEXT", 251 (Invo_Context_Blk_Type), 252 (Reference)); 253 254 procedure Get_Invo_Handle ( 255 Result : out Invo_Handle_Type; -- return value 256 Invo_Context : Invo_Context_Blk_Type); 257 258 pragma Import (External, Get_Invo_Handle); 259 260 pragma Import_Valued_Procedure (Get_Invo_Handle, "LIB$GET_INVO_HANDLE", 261 (Invo_Handle_Type, Invo_Context_Blk_Type), 262 (Value, Reference)); 263 264 ICB : Invo_Context_Blk_Type; 265 Invo_Handle : aliased Invo_Handle_Type; 266 267 begin 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; 273 274end System.Machine_State_Operations; 275