------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- SYSTEM.MACHINE_STATE_OPERATIONS -- -- -- -- B o d y -- -- (Version for Alpha/VMS) -- -- -- -- Copyright (C) 2001-2002 Ada Core Technologies, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -- This version of System.Machine_State_Operations is for use on -- Alpha systems running VMS. with System.Memory; with System.Aux_DEC; use System.Aux_DEC; with Unchecked_Conversion; package body System.Machine_State_Operations is use System.Exceptions; subtype Cond_Value_Type is Unsigned_Longword; -- Record layouts copied from Starlet. type ICB_Fflags_Bits_Type is record Exception_Frame : Boolean; Ast_Frame : Boolean; Bottom_Of_Stack : Boolean; Base_Frame : Boolean; Filler_1 : Unsigned_20; end record; for ICB_Fflags_Bits_Type use record Exception_Frame at 0 range 0 .. 0; Ast_Frame at 0 range 1 .. 1; Bottom_Of_Stack at 0 range 2 .. 2; Base_Frame at 0 range 3 .. 3; Filler_1 at 0 range 4 .. 23; end record; for ICB_Fflags_Bits_Type'Size use 24; type ICB_Hdr_Quad_Type is record Context_Length : Unsigned_Longword; Fflags_Bits : ICB_Fflags_Bits_Type; Block_Version : Unsigned_Byte; end record; for ICB_Hdr_Quad_Type use record Context_Length at 0 range 0 .. 31; Fflags_Bits at 4 range 0 .. 23; Block_Version at 7 range 0 .. 7; end record; for ICB_Hdr_Quad_Type'Size use 64; type Invo_Context_Blk_Type is record Hdr_Quad : ICB_Hdr_Quad_Type; -- The first quadword contains: -- o The length of the structure in bytes (a longword field) -- o The frame flags (a 3 byte field of bits) -- o The version number (a 1 byte field) Procedure_Descriptor : Unsigned_Quadword; -- The address of the procedure descriptor for the procedure Program_Counter : Integer_64; -- The current PC of a given procedure invocation Processor_Status : Integer_64; -- The current PS of a given procedure invocation Ireg : Unsigned_Quadword_Array (0 .. 30); Freg : Unsigned_Quadword_Array (0 .. 30); -- The register contents areas. 31 for scalars, 31 for float. System_Defined : Unsigned_Quadword_Array (0 .. 1); -- The following is an "internal" area that's reserved for use by -- the operating system. It's size may vary over time. -- Chfctx_Addr : Unsigned_Quadword; -- Defined as a comment since it overlaps other fields Filler_1 : String (1 .. 0); -- Align to octaword end record; for Invo_Context_Blk_Type use record Hdr_Quad at 0 range 0 .. 63; Procedure_Descriptor at 8 range 0 .. 63; Program_Counter at 16 range 0 .. 63; Processor_Status at 24 range 0 .. 63; Ireg at 32 range 0 .. 1983; Freg at 280 range 0 .. 1983; System_Defined at 528 range 0 .. 127; -- Component representation spec(s) below are defined as -- comments since they overlap other fields -- Chfctx_Addr at 528 range 0 .. 63; Filler_1 at 544 range 0 .. -1; end record; for Invo_Context_Blk_Type'Size use 4352; subtype Invo_Handle_Type is Unsigned_Longword; type Invo_Handle_Access_Type is access all Invo_Handle_Type; function Fetch is new Fetch_From_Address (Code_Loc); function To_Invo_Handle_Access is new Unchecked_Conversion (Machine_State, Invo_Handle_Access_Type); function To_Machine_State is new Unchecked_Conversion (System.Address, Machine_State); ---------------------------- -- Allocate_Machine_State -- ---------------------------- function Allocate_Machine_State return Machine_State is begin return To_Machine_State (Memory.Alloc (Invo_Handle_Type'Max_Size_In_Storage_Elements)); end Allocate_Machine_State; ------------------- -- Enter_Handler -- ------------------- procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is procedure Get_Invo_Context ( Result : out Unsigned_Longword; -- return value Invo_Handle : Invo_Handle_Type; Invo_Context : out Invo_Context_Blk_Type); pragma Interface (External, Get_Invo_Context); pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT", (Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type), (Value, Value, Reference)); ICB : Invo_Context_Blk_Type; procedure Goto_Unwind ( Status : out Cond_Value_Type; -- return value Target_Invo : Address := Address_Zero; Target_PC : Address := Address_Zero; New_R0 : Unsigned_Quadword := Unsigned_Quadword'Null_Parameter; New_R1 : Unsigned_Quadword := Unsigned_Quadword'Null_Parameter); pragma Interface (External, Goto_Unwind); pragma Import_Valued_Procedure (Goto_Unwind, "SYS$GOTO_UNWIND", (Cond_Value_Type, Address, Address, Unsigned_Quadword, Unsigned_Quadword), (Value, Reference, Reference, Reference, Reference)); Status : Cond_Value_Type; begin Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB); Goto_Unwind (Status, System.Address (To_Invo_Handle_Access (M).all), Handler); end Enter_Handler; ---------------- -- Fetch_Code -- ---------------- function Fetch_Code (Loc : Code_Loc) return Code_Loc is begin -- The starting address is in the second longword pointed to by Loc. return Fetch (System.Aux_DEC."+" (Loc, 8)); end Fetch_Code; ------------------------ -- Free_Machine_State -- ------------------------ procedure Free_Machine_State (M : in out Machine_State) is begin Memory.Free (Address (M)); M := Machine_State (Null_Address); end Free_Machine_State; ------------------ -- Get_Code_Loc -- ------------------ function Get_Code_Loc (M : Machine_State) return Code_Loc is procedure Get_Invo_Context ( Result : out Unsigned_Longword; -- return value Invo_Handle : in Invo_Handle_Type; Invo_Context : out Invo_Context_Blk_Type); pragma Interface (External, Get_Invo_Context); pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT", (Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type), (Value, Value, Reference)); Asm_Call_Size : constant := 4; -- Under VMS a call -- asm instruction takes 4 bytes. So we must remove this amount. ICB : Invo_Context_Blk_Type; Status : Cond_Value_Type; begin Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB); if (Status and 1) /= 1 then return Code_Loc (System.Null_Address); end if; return Code_Loc (ICB.Program_Counter - Asm_Call_Size); end Get_Code_Loc; -------------------------- -- Machine_State_Length -- -------------------------- function Machine_State_Length return System.Storage_Elements.Storage_Offset is use System.Storage_Elements; begin return Invo_Handle_Type'Size / 8; end Machine_State_Length; --------------- -- Pop_Frame -- --------------- procedure Pop_Frame (M : Machine_State; Info : Subprogram_Info_Type) is pragma Warnings (Off, Info); procedure Get_Prev_Invo_Handle ( Result : out Invo_Handle_Type; -- return value ICB : in Invo_Handle_Type); pragma Interface (External, Get_Prev_Invo_Handle); pragma Import_Valued_Procedure (Get_Prev_Invo_Handle, "LIB$GET_PREV_INVO_HANDLE", (Invo_Handle_Type, Invo_Handle_Type), (Value, Value)); Prev_Handle : aliased Invo_Handle_Type; begin Get_Prev_Invo_Handle (Prev_Handle, To_Invo_Handle_Access (M).all); To_Invo_Handle_Access (M).all := Prev_Handle; end Pop_Frame; ----------------------- -- Set_Machine_State -- ----------------------- procedure Set_Machine_State (M : Machine_State) is procedure Get_Curr_Invo_Context (Invo_Context : out Invo_Context_Blk_Type); pragma Interface (External, Get_Curr_Invo_Context); pragma Import_Valued_Procedure (Get_Curr_Invo_Context, "LIB$GET_CURR_INVO_CONTEXT", (Invo_Context_Blk_Type), (Reference)); procedure Get_Invo_Handle ( Result : out Invo_Handle_Type; -- return value Invo_Context : in Invo_Context_Blk_Type); pragma Interface (External, Get_Invo_Handle); pragma Import_Valued_Procedure (Get_Invo_Handle, "LIB$GET_INVO_HANDLE", (Invo_Handle_Type, Invo_Context_Blk_Type), (Value, Reference)); ICB : Invo_Context_Blk_Type; Invo_Handle : aliased Invo_Handle_Type; begin Get_Curr_Invo_Context (ICB); Get_Invo_Handle (Invo_Handle, ICB); To_Invo_Handle_Access (M).all := Invo_Handle; Pop_Frame (M, System.Null_Address); end Set_Machine_State; ------------------------------ -- Set_Signal_Machine_State -- ------------------------------ procedure Set_Signal_Machine_State (M : Machine_State; Context : System.Address) is pragma Warnings (Off, M); pragma Warnings (Off, Context); begin null; end Set_Signal_Machine_State; end System.Machine_State_Operations;