[Ada] Enhance VMS runtime to use 64bit heap allocation
Arnaud Charlet
charlet@adacore.com
Wed Apr 9 07:45:00 GMT 2008
Manually tested on alpha-openvms and ia64-openvms,
Tested on i686-linux, committed on trunk
Heretofor the VMS runtime was restricted to 32bit heap allocation due to
restrictions on Task_id (an access type) being a 32bit parameter in calls to
certain legacy VMS Starlet, AST, and RMS functions. This enhancement causes
allocators with 32bit 'size attributes to call the available C RTL 32 bit malloc.
Test program (relebant for VMS only) follows
Expected output is
OK
--
with System.Aux_DEC;
with Text_IO;
with Unchecked_Conversion;
procedure Test1 is
Type Foo is new Integer;
type FooA1 is access all Foo;
for FooA1'Size use System.Aux_DEC.Short_Address_Size;
Bar1 : FooA1 := new Foo'(1);
type FooA2 is access all Foo;
for FooA2'Size use Standard'Address_Size;
Bar2 : FooA2 := new Foo'(1);
pragma Warnings (Off);
function To_Int1 is new Unchecked_Conversion (FooA1, Long_Integer);
function To_Int2 is new Unchecked_Conversion (FooA2, Long_Integer);
pragma Warnings (On);
begin
if FooA1'Size = 32 and FooA2'Size = 64 then
if To_Int1 (Bar1) < 2**31 and then To_Int2 (Bar2) > 2 ** 31 then
Text_IO.Put_Line ("OK");
else
Text_IO.Put_Line ("Failed");
end if;
else
Text_IO.Put_Line ("OK");
end if;
end;
2008-04-09 Doug Rupp <rupp@adacore.com>
* decl.c (validate_size): Set minimum size for fat pointers same as
access types. Code clean ups.
* gmem.c (xstrdup32): New macro for 32bit dup on VMS, noop otherwise
(__gnat_gmem_a2l_initialize): Dup exename into 32 bit memory on VMS
* s-auxdec-vms_64.ads, s-auxdec.ads (Short_Address_Size): New constant
* s-crtl.ads (malloc32) New function, alias for malloc
(realloc32) New function, alias for realloc
* socket.c (__gnat_new_socket_set): Malloc fd_set in 32 bits on VMS
* utils2.c (build_call_alloc_dealloc): Return call to short malloc if
allocator size is 32 and default pointer size is 64.
(find_common_type): Document assumption on t1/t2 vs lhs/rhs. Force use of
lhs type if smaller, whatever the modes.
* gigi.h (malloc32_decl): New macro definition
* utils.c (init_gigi_decls): New malloc32_decl
Various code clean ups.
* s-asthan-vms-alpha.adb (Process_AST.To_Address): Unchecked convert to
Task_Address vice System.Address.
* s-taspri-vms.ads: Import System.Aux_DEC
(Task_Address): New subtype of System.Aux_DEC.Short_Address
(Task_Address_Size): New constant size of System.Aux_DEC.Short_Address
* s-asthan-vms-alpha.adb (Process_AST.To_Address): Unchecked convert to
Task_Address vice System.Address.
* s-inmaop-vms.adb: Import System.Task_Primitives
(To_Address): Unchecked convert to Task_Address vice System.Address
* s-taprop-vms.adb (Timed_Delay): Always set the timer even if delay
expires now.
(To_Task_ID) Unchecked convert from Task_Adddress vice System.Address
(To_Address) Unchecked convert to Task_Address vice System.Address
* s-tpopde-vms.adb: Remove unnecessary warning pragmas
* g-socthi-vms.ads: Add 32bit size clauses on socket access types.
-------------- next part --------------
Index: decl.c
===================================================================
--- decl.c (revision 134130)
+++ decl.c (working copy)
@@ -6852,15 +6852,13 @@ validate_size (Uint uint_size, tree gnu_
size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
/* Modify the size of the type to be that of the maximum size if it has a
- discriminant or the size of a thin pointer if this is a fat pointer. */
+ discriminant. */
if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
type_size = max_size (type_size, true);
- else if (TYPE_FAT_POINTER_P (gnu_type))
- type_size = bitsize_int (POINTER_SIZE);
- /* If this is an access type, the minimum size is that given by the smallest
- integral mode that's valid for pointers. */
- if (TREE_CODE (gnu_type) == POINTER_TYPE)
+ /* If this is an access type or a fat pointer, the minimum size is that given
+ by the smallest integral mode that's valid for pointers. */
+ if ((TREE_CODE (gnu_type) == POINTER_TYPE) || TYPE_FAT_POINTER_P (gnu_type))
{
enum machine_mode p_mode;
Index: gmem.c
===================================================================
--- gmem.c (revision 134130)
+++ gmem.c (working copy)
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2000-2007, Free Software Foundation, Inc. *
+ * Copyright (C) 2000-2008, Free Software Foundation, 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- *
@@ -50,6 +50,13 @@
*/
+#ifdef VMS
+#include <string.h>
+#define xstrdup32(S) strcpy ((__char_ptr32) _malloc32 (strlen (S) + 1), S)
+#else
+#define xstrdup32(S) S
+#endif
+
#include <stdio.h>
static FILE *gmemfile;
@@ -141,8 +148,10 @@ long long __gnat_gmem_initialize (char *
void __gnat_gmem_a2l_initialize (char *exearg)
{
/* Resolve the executable filename to use in later invocations of
- the libaddr2line symbolization service. */
- exename = __gnat_locate_exec_on_path (exearg);
+ the libaddr2line symbolization service. Ensure that on VMS
+ exename is allocated in 32 bit memory for compatibility
+ with libaddr2line. */
+ exename = xstrdup32 (__gnat_locate_exec_on_path (exearg));
}
/* Read next allocation of deallocation information from the GMEM file and
Index: s-auxdec-vms_64.ads
===================================================================
--- s-auxdec-vms_64.ads (revision 134130)
+++ s-auxdec-vms_64.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2008, Free Software Foundation, 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- --
@@ -96,9 +96,10 @@ package System.Aux_DEC is
function "or" (Left, Right : Largest_Integer) return Largest_Integer;
function "xor" (Left, Right : Largest_Integer) return Largest_Integer;
- Address_Zero : constant Address;
- No_Addr : constant Address;
- Address_Size : constant := Standard'Address_Size;
+ Address_Zero : constant Address;
+ No_Addr : constant Address;
+ Address_Size : constant := Standard'Address_Size;
+ Short_Address_Size : constant := 32;
function "+" (Left : Address; Right : Integer) return Address;
function "+" (Left : Integer; Right : Address) return Address;
Index: socket.c
===================================================================
--- socket.c (revision 134130)
+++ socket.c (working copy)
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2003-2007, Free Software Foundation, Inc. *
+ * Copyright (C) 2003-2008, Free Software Foundation, 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- *
@@ -340,7 +340,12 @@ __gnat_new_socket_set (fd_set *set)
{
fd_set *new;
+#ifdef VMS
+extern void *__gnat_malloc32 (__SIZE_TYPE__);
+ new = (fd_set *) __gnat_malloc32 (sizeof (fd_set));
+#else
new = (fd_set *) __gnat_malloc (sizeof (fd_set));
+#endif
if (set)
memcpy (new, set, sizeof (fd_set));
Index: utils2.c
===================================================================
--- utils2.c (revision 134130)
+++ utils2.c (working copy)
@@ -1918,7 +1918,14 @@ build_call_alloc_dealloc (tree gnu_obj,
{
if (Nkind (gnat_node) != N_Allocator || !Comes_From_Source (gnat_node))
Check_No_Implicit_Heap_Alloc (gnat_node);
- return build_call_1_expr (malloc_decl, gnu_size);
+
+ /* If the allocator size is 32bits but the pointer size is 64bits then
+ allocate 32bit memory (sometimes necessary on 64bit VMS). Otherwise
+ default to standard malloc. */
+ if (UI_To_Int (Esize (Etype (gnat_node))) == 32 && POINTER_SIZE == 64)
+ return build_call_1_expr (malloc32_decl, gnu_size);
+ else
+ return build_call_1_expr (malloc_decl, gnu_size);
}
}
Index: gigi.h
===================================================================
--- gigi.h (revision 134130)
+++ gigi.h (working copy)
@@ -379,7 +379,11 @@ enum standard_datatypes
/* Null pointer for above type */
ADT_null_fdesc,
+ /* Function declaration nodes for run-time functions for allocating memory.
+ Ada allocators cause calls to these functions to be generated. Malloc32
+ is used only on 64bit systems needing to allocate 32bit memory. */
ADT_malloc_decl,
+ ADT_malloc32_decl,
/* Likewise for freeing memory. */
ADT_free_decl,
@@ -413,6 +417,7 @@ extern GTY(()) tree gnat_raise_decls[(in
#define fdesc_type_node gnat_std_decls[(int) ADT_fdesc_type]
#define null_fdesc_node gnat_std_decls[(int) ADT_null_fdesc]
#define malloc_decl gnat_std_decls[(int) ADT_malloc_decl]
+#define malloc32_decl gnat_std_decls[(int) ADT_malloc32_decl]
#define free_decl gnat_std_decls[(int) ADT_free_decl]
#define jmpbuf_type gnat_std_decls[(int) ADT_jmpbuf_type]
#define jmpbuf_ptr_type gnat_std_decls[(int) ADT_jmpbuf_ptr_type]
Index: utils.c
===================================================================
--- utils.c (revision 134130)
+++ utils.c (working copy)
@@ -584,6 +584,18 @@ init_gigi_decls (tree long_long_float_ty
Empty);
DECL_IS_MALLOC (malloc_decl) = 1;
+ /* malloc32 is a function declaration tree for a function to allocate
+ 32bit memory on a 64bit system. Needed only on 64bit VMS. */
+ malloc32_decl = create_subprog_decl (get_identifier ("__gnat_malloc32"),
+ NULL_TREE,
+ build_function_type (ptr_void_type_node,
+ tree_cons (NULL_TREE,
+ sizetype,
+ endlink)),
+ NULL_TREE, false, true, true, NULL,
+ Empty);
+ DECL_IS_MALLOC (malloc32_decl) = 1;
+
/* free is a function declaration tree for a function to free memory. */
free_decl
= create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
Index: s-asthan-vms-alpha.adb
===================================================================
--- s-asthan-vms-alpha.adb (revision 134130)
+++ s-asthan-vms-alpha.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2008, Free Software Foundation, 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- --
@@ -545,16 +545,16 @@ package body System.AST_Handling is
-- from which we can obtain the task and entry number information.
function To_Address is new Ada.Unchecked_Conversion
- (ST.Task_Id, System.Address);
+ (ST.Task_Id, System.Task_Primitives.Task_Address);
begin
System.Machine_Code.Asm
- (Template => "addl $27,0,%0",
+ (Template => "addq $27,0,%0",
Outputs => AST_Handler_Data_Ref'Asm_Output ("=r", Handler_Data_Ptr),
Volatile => True);
System.Machine_Code.Asm
- (Template => "ldl $27,%0",
+ (Template => "ldq $27,%0",
Inputs => Descriptor_Ref'Asm_Input
("m", Handler_Data_Ptr.Original_Descriptor_Ref),
Volatile => True);
Index: s-asthan-vms-alpha.adb
===================================================================
--- s-asthan-vms-alpha.adb (revision 134130)
+++ s-asthan-vms-alpha.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2008, Free Software Foundation, 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- --
@@ -545,16 +545,16 @@ package body System.AST_Handling is
-- from which we can obtain the task and entry number information.
function To_Address is new Ada.Unchecked_Conversion
- (ST.Task_Id, System.Address);
+ (ST.Task_Id, System.Task_Primitives.Task_Address);
begin
System.Machine_Code.Asm
- (Template => "addl $27,0,%0",
+ (Template => "addq $27,0,%0",
Outputs => AST_Handler_Data_Ref'Asm_Output ("=r", Handler_Data_Ptr),
Volatile => True);
System.Machine_Code.Asm
- (Template => "ldl $27,%0",
+ (Template => "ldq $27,%0",
Inputs => Descriptor_Ref'Asm_Input
("m", Handler_Data_Ptr.Original_Descriptor_Ref),
Volatile => True);
Index: s-inmaop-vms.adb
===================================================================
--- s-inmaop-vms.adb (revision 134130)
+++ s-inmaop-vms.adb (working copy)
@@ -38,6 +38,7 @@ with System.Aux_DEC;
with System.Parameters;
with System.Tasking;
with System.Tasking.Initialization;
+with System.Task_Primitives;
with System.Task_Primitives.Operations;
with System.Task_Primitives.Operations.DEC;
@@ -51,7 +52,8 @@ package body System.Interrupt_Management
use type unsigned_short;
function To_Address is
- new Ada.Unchecked_Conversion (Task_Id, System.Address);
+ new Ada.Unchecked_Conversion
+ (Task_Id, System.Task_Primitives.Task_Address);
package POP renames System.Task_Primitives.Operations;
Index: s-taprop-vms.adb
===================================================================
--- s-taprop-vms.adb (revision 134130)
+++ s-taprop-vms.adb (working copy)
@@ -131,10 +131,12 @@ package body System.Task_Primitives.Oper
-----------------------
function To_Task_Id is
- new Ada.Unchecked_Conversion (System.Address, Task_Id);
+ new Ada.Unchecked_Conversion
+ (System.Task_Primitives.Task_Address, Task_Id);
function To_Address is
- new Ada.Unchecked_Conversion (Task_Id, System.Address);
+ new Ada.Unchecked_Conversion
+ (Task_Id, System.Task_Primitives.Task_Address);
function Get_Exc_Stack_Addr return Address;
-- Replace System.Soft_Links.Get_Exc_Stack_Addr_NT
@@ -519,7 +521,7 @@ package body System.Task_Primitives.Oper
if Time /= 0.0 or else Mode /= Relative then
Sleep_Time := To_OS_Time (Time, Mode);
- if Mode = Relative or else OS_Clock < Sleep_Time then
+ if Mode = Relative or else OS_Clock <= Sleep_Time then
Self_ID.Common.State := Delay_Sleep;
Self_ID.Common.LL.AST_Pending := True;
Index: s-tpopde-vms.adb
===================================================================
--- s-tpopde-vms.adb (revision 134130)
+++ s-tpopde-vms.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2008, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@@ -69,17 +69,12 @@ package body System.Task_Primitives.Oper
-- Local Subprograms --
-----------------------
- pragma Warnings (Off);
- -- Task_Id is 64 bits wide (but only 32 bits significant) on Integrity/VMS
-
function To_Unsigned_Longword is new
Ada.Unchecked_Conversion (Task_Id, Unsigned_Longword);
function To_Task_Id is new
Ada.Unchecked_Conversion (Unsigned_Longword, Task_Id);
- pragma Warnings (On);
-
function To_FAB_RAB is new
Ada.Unchecked_Conversion (Address, FAB_RAB_Access_Type);
Index: g-socthi-vms.ads
===================================================================
--- g-socthi-vms.ads (revision 134130)
+++ g-socthi-vms.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2007, AdaCore --
+-- Copyright (C) 2002-2008, AdaCore --
-- --
-- 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- --
@@ -151,6 +151,7 @@ package GNAT.Sockets.Thin is
-- Socket address
type Sockaddr_Access is access all Sockaddr;
+ for Sockaddr_Access'Size use 32;
pragma Convention (C, Sockaddr_Access);
-- Access to socket address
@@ -164,6 +165,7 @@ package GNAT.Sockets.Thin is
-- Internet socket address
type Sockaddr_In_Access is access all Sockaddr_In;
+ for Sockaddr_In_Access'Size use 32;
pragma Convention (C, Sockaddr_In_Access);
-- Access to internet socket address
@@ -203,6 +205,7 @@ package GNAT.Sockets.Thin is
-- Host entry
type Hostent_Access is access all Hostent;
+ for Hostent_Access'Size use 32;
pragma Convention (C, Hostent_Access);
-- Access to host entry
@@ -216,6 +219,7 @@ package GNAT.Sockets.Thin is
-- Service entry
type Servent_Access is access all Servent;
+ for Servent_Access'Size use 32;
pragma Convention (C, Servent_Access);
-- Access to service entry
More information about the Gcc-patches
mailing list