PR modula2/118600 Assigning to a record causes alignment exception

This patch recursively tests every assignment (of a constructor
to a designator) to ensure the types are GCC equivalent.  If they
are equivalent then it uses gimple assignment and if not then it
copies a structure by field and uses __builtin_strncpy to copy a
string cst into an array.  Unions are copied by __builtin_memcpy.

gcc/m2/ChangeLog:

	PR modula2/118600
	* gm2-compiler/M2GenGCC.mod (PerformCodeBecomes): New procedure.
	(CodeBecomes): Refactor and call PerformCodeBecomes.
	* gm2-gcc/m2builtins.cc (gm2_strncpy_node): New global variable.
	(DoBuiltinStrNCopy): New function.
	(m2builtins_BuiltinStrNCopy): New function.
	(m2builtins_init): Initialize gm2_strncpy_node.
	* gm2-gcc/m2builtins.def (BuiltinStrNCopy): New procedure
	function.
	* gm2-gcc/m2builtins.h (m2builtins_BuiltinStrNCopy): New
	function.
	* gm2-gcc/m2statement.cc (copy_record_fields): New function.
	(copy_array): Ditto.
	(copy_strncpy): Ditto.
	(copy_memcpy): Ditto.
	(CopyByField_Lower): Ditto.
	(m2statement_CopyByField): Ditto.
	* gm2-gcc/m2statement.def (CopyByField): New procedure function.
	* gm2-gcc/m2statement.h (m2statement_CopyByField): New function.
	* gm2-gcc/m2type.cc (check_record_fields): Ditto.
	(check_array_types): Ditto.
	(m2type_IsGccStrictTypeEquivalent): Ditto.
	* gm2-gcc/m2type.def (IsGccStrictTypeEquivalent): New procedure
	function.
	* gm2-gcc/m2type.h (m2type_IsAddress): Replace return type int
	with bool.

Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>

gcc/m2/gm2-compiler/M2GenGCC.mod

@@ -43,7 +43,7 @@ FROM SymbolTable IMPORT PushSize, PopSize, PushValue, PopValue,
                         IsConst, IsConstSet, IsProcedure, IsProcType,
                         IsVar, IsVarParamAny, IsTemporary, IsTuple,
                         IsEnumeration,
-                        IsUnbounded, IsArray, IsSet, IsConstructor,
+                        IsUnbounded, IsArray, IsSet, IsConstructor, IsConstructorConstant,
                         IsProcedureVariable,
                         IsUnboundedParamAny,
                         IsRecordField, IsFieldVarient, IsVarient, IsRecord,
@@ -232,7 +232,7 @@ FROM m2statement IMPORT BuildAsm, BuildProcedureCallTree, BuildParam, BuildFunct
                         BuildReturnValueCode, SetLastFunction,
                         BuildIncludeVarConst, BuildIncludeVarVar,
                         BuildExcludeVarConst, BuildExcludeVarVar,
-                        BuildBuiltinCallTree,
+                        BuildBuiltinCallTree, CopyByField,
 			GetParamTree, BuildCleanUp,
 			BuildTryFinally,
 			GetLastFunction, SetLastFunction,
@@ -241,7 +241,7 @@ FROM m2statement IMPORT BuildAsm, BuildProcedureCallTree, BuildParam, BuildFunct
 FROM m2type IMPORT ChainOnParamValue, GetPointerType, GetIntegerType, AddStatement,
                    GetCardinalType, GetWordType, GetM2ZType, GetM2RType, GetM2CType,
                    BuildCharConstant, AddStringToTreeList, BuildArrayStringConstructor,
-                   GetArrayNoOfElements, GetTreeType ;
+                   GetArrayNoOfElements, GetTreeType, IsGccStrictTypeEquivalent ;
 
 FROM m2block IMPORT RememberConstant, pushGlobalScope, popGlobalScope, finishFunctionDecl,
                     pushFunctionScope, popFunctionScope,
@@ -3497,6 +3497,29 @@ BEGIN
 END checkDeclare ;
 
 
+(*
+   PerformCodeBecomes -
+*)
+
+PROCEDURE PerformCodeBecomes (location: location_t;
+                              virtpos: CARDINAL; des, expr: CARDINAL) ;
+VAR
+   destree, exprtree: tree ;
+BEGIN
+   destree := Mod2Gcc (des) ;
+   exprtree := FoldConstBecomes (virtpos, des, expr) ;
+   IF IsVar (des) AND IsVariableSSA (des)
+   THEN
+      Replace (des, exprtree)
+   ELSIF IsGccStrictTypeEquivalent (destree, exprtree)
+   THEN
+      BuildAssignmentStatement (location, destree, exprtree)
+   ELSE
+      CopyByField (location, destree, exprtree)
+   END
+END PerformCodeBecomes ;
+
+
 (*
 ------------------------------------------------------------------------------
    := Operator
@@ -3576,14 +3599,7 @@ BEGIN
       ELSE
          IF checkBecomes (des, expr, virtpos, despos, exprpos)
          THEN
-            IF IsVar (des) AND IsVariableSSA (des)
-            THEN
-               Replace (des, FoldConstBecomes (virtpos, des, expr))
-            ELSE
-               BuildAssignmentStatement (location,
-                                         Mod2Gcc (des),
-                                         FoldConstBecomes (virtpos, des, expr))
-            END
+            PerformCodeBecomes (location, virtpos, des, expr)
          ELSE
             SubQuad (quad)  (* We don't want multiple errors for the quad.  *)
          END

gcc/m2/gm2-gcc/m2builtins.cc

@@ -418,6 +418,7 @@ static GTY (()) tree ldouble_ftype_ldouble;
 static GTY (()) tree gm2_alloca_node;
 static GTY (()) tree gm2_memcpy_node;
 static GTY (()) tree gm2_memset_node;
+static GTY (()) tree gm2_strncpy_node;
 static GTY (()) tree gm2_isfinite_node;
 static GTY (()) tree gm2_isnan_node;
 static GTY (()) tree gm2_huge_valf_node;
@@ -1039,6 +1040,18 @@ DoBuiltinMemCopy (location_t location, tree dest, tree src, tree bytes)
   return call;
 }
 
+static tree
+DoBuiltinStrNCopy (location_t location, tree dest, tree src, tree bytes)
+{
+  tree functype = TREE_TYPE (gm2_strncpy_node);
+  tree rettype = TREE_TYPE (functype);
+  tree funcptr
+      = build1 (ADDR_EXPR, build_pointer_type (functype), gm2_strncpy_node);
+  tree call
+      = m2treelib_DoCall3 (location, rettype, funcptr, dest, src, bytes);
+  return call;
+}
+
 static tree
 DoBuiltinAlloca (location_t location, tree bytes)
 {
@@ -1105,6 +1118,14 @@ m2builtins_BuiltInHugeValLong (location_t location)
   return call;
 }
 
+/* BuiltinStrNCopy copy at most n chars from address src to dest.  */
+
+tree
+m2builtins_BuiltinStrNCopy (location_t location, tree dest, tree src, tree n)
+{
+  return DoBuiltinStrNCopy (location, dest, src, n);
+}
+
 static void
 create_function_prototype (location_t location,
                            struct builtin_function_entry *fe)
@@ -1580,6 +1601,7 @@ m2builtins_init (location_t location)
   gm2_alloca_node = find_builtin_tree ("__builtin_alloca");
   gm2_memcpy_node = find_builtin_tree ("__builtin_memcpy");
   gm2_memset_node = find_builtin_tree ("__builtin_memset");
+  gm2_strncpy_node = find_builtin_tree ("__builtin_strncpy");  
   gm2_huge_valf_node = find_builtin_tree ("__builtin_huge_valf");
   gm2_huge_val_node = find_builtin_tree ("__builtin_huge_val");
   gm2_huge_vall_node = find_builtin_tree ("__builtin_huge_vall");

gcc/m2/gm2-gcc/m2builtins.def

@@ -24,12 +24,6 @@ DEFINITION MODULE FOR "C" m2builtins ;
 FROM CDataTypes IMPORT CharStar, ConstCharStar ;
 FROM gcctypes IMPORT location_t, tree ;
 
-EXPORT QUALIFIED GetBuiltinConst, GetBuiltinConstType,
-                 GetBuiltinTypeInfoType, GetBuiltinTypeInfo,
-                 BuiltinExists, BuildBuiltinTree,
-                 BuiltinMemCopy, BuiltinMemSet, BuiltInAlloca,
-		 BuiltInIsfinite ;
-
 
 (*
    GetBuiltinConst - returns the gcc tree of a built in constant, name.
@@ -124,4 +118,11 @@ PROCEDURE BuiltInAlloca (location: location_t; n: tree) : tree ;
 PROCEDURE BuiltInIsfinite (location: location_t; e: tree) : tree ;
 
 
+(*
+   BuiltinStrNCopy - copy at most n characters from src to dest.
+*)
+
+PROCEDURE BuiltinStrNCopy (location: location_t; dest, src, n: tree) : tree ;
+
+
 END m2builtins.

gcc/m2/gm2-gcc/m2builtins.h

@@ -54,6 +54,8 @@ EXTERN tree m2builtins_BuildBuiltinTree (location_t location, char *name);
 EXTERN tree m2builtins_BuiltInHugeVal (location_t location);
 EXTERN tree m2builtins_BuiltInHugeValShort (location_t location);
 EXTERN tree m2builtins_BuiltInHugeValLong (location_t location);
+EXTERN tree m2builtins_BuiltinStrNCopy (location_t location, tree dest, tree src, tree n);
+
 EXTERN void m2builtins_init (location_t location);
 
 #undef EXTERN

gcc/m2/gm2-gcc/m2statement.cc

@@ -36,6 +36,7 @@ along with GNU Modula-2; see the file COPYING3.  If not see
 #include "m2treelib.h"
 #include "m2type.h"
 #include "m2convert.h"
+#include "m2builtins.h"
 #include "m2pp.h"
 
 static GTY (()) tree param_list = NULL_TREE; /* Ready for the next time we
@@ -154,6 +155,120 @@ m2statement_SetEndLocation (location_t location)
     cfun->function_end_locus = location;
 }
 
+/* copy_record_fields copy each record field from right to left.  */
+
+static
+void
+copy_record_fields (location_t location, tree left, tree right)
+{
+  unsigned int i;
+  tree right_value;
+  tree left_type = TREE_TYPE (left);
+  vec<constructor_elt, va_gc> *values = CONSTRUCTOR_ELTS (right);
+  FOR_EACH_CONSTRUCTOR_VALUE (values, i, right_value)
+    {
+      tree left_field = m2treelib_get_field_no (left_type, NULL_TREE, false, i);
+      tree left_ref = m2expr_BuildComponentRef (location, left, left_field);
+      m2statement_CopyByField (location, left_ref, right_value);
+    }
+}
+
+/* copy_array copy each element of an array from array right to array left.  */
+
+static
+void
+copy_array (location_t location, tree left, tree right)
+{
+  unsigned int i;
+  tree value;
+  vec<constructor_elt, va_gc> *values = CONSTRUCTOR_ELTS (right);
+  tree array_type = TREE_TYPE (left);
+  tree index_type = TYPE_DOMAIN (array_type);
+  tree elt_type = TREE_TYPE (array_type);
+  tree low_indice = TYPE_MIN_VALUE (index_type);
+  low_indice
+      = m2convert_BuildConvert (location, index_type, low_indice, false);
+  FOR_EACH_CONSTRUCTOR_VALUE (values, i, value)
+    {
+      tree idx = m2decl_BuildIntegerConstant (i);
+      idx = m2convert_BuildConvert (location, index_type, idx, false);
+      tree array_ref = build4_loc (location, ARRAY_REF, elt_type, left,
+				   idx, low_indice, NULL_TREE);
+      m2statement_CopyByField (location, array_ref, value);      
+    }
+}
+
+/* copy_array cst into left using strncpy.  */
+
+static
+void
+copy_strncpy (location_t location, tree left, tree cst)
+{
+  tree result = m2builtins_BuiltinStrNCopy (location,
+					    m2expr_BuildAddr (location, left, false),
+					    m2expr_BuildAddr (location, cst, false),
+					    m2decl_BuildIntegerConstant (m2expr_StringLength (cst)));
+  TREE_SIDE_EFFECTS (result) = true;
+  TREE_USED (left) = true;
+  TREE_USED (cst) = true;
+  add_stmt (location, result);
+}
+
+/* copy_memcpy copy right into left using builtin_memcpy.  */
+
+static
+void
+copy_memcpy (location_t location, tree left, tree right)
+{
+  tree result = m2builtins_BuiltinMemCopy (location,
+					   m2expr_BuildAddr (location, left, false),
+					   m2expr_BuildAddr (location, right, false),
+					   m2expr_GetSizeOf (location, left));
+  TREE_SIDE_EFFECTS (result) = true;
+  TREE_USED (left) = true;
+  TREE_USED (right) = true;
+  add_stmt (location, result);
+}
+
+/* CopyByField_Lower copy right to left using memcpy for unions,
+   strncpy for string cst, field assignment for records,
+   array element assignment for array constructors.  For all
+   other types it uses BuildAssignmentStatement.  */
+
+static
+void
+CopyByField_Lower (location_t location,
+		   tree left, tree right)
+{
+  tree left_type = TREE_TYPE (left);
+  enum tree_code right_code = TREE_CODE (right);
+  enum tree_code left_code = TREE_CODE (left_type);
+
+  if (left_code == RECORD_TYPE && right_code == CONSTRUCTOR)
+    copy_record_fields (location, left, right);
+  else if (left_code == ARRAY_TYPE && right_code == CONSTRUCTOR)
+    copy_array (location, left, right);
+  else if (left_code == UNION_TYPE && right_code == CONSTRUCTOR)
+    copy_memcpy (location, left, right);
+  else if (right_code == STRING_CST)
+    copy_strncpy (location, left, right);
+  else
+    m2statement_BuildAssignmentStatement (location, left, right);    
+}
+
+/* CopyByField recursively checks each field to ensure GCC
+   type equivalence and if so it uses assignment.
+   Otherwise use strncpy or memcpy depending upon type.  */
+
+void
+m2statement_CopyByField (location_t location, tree des, tree expr)
+{
+  if (m2type_IsGccStrictTypeEquivalent (des, expr))
+    m2statement_BuildAssignmentStatement (location, des, expr);
+  else
+    CopyByField_Lower (location, des, expr);
+}
+
 /* BuildAssignmentTree builds the assignment of, des, and, expr.
    It returns, des.  */
 

gcc/m2/gm2-gcc/m2statement.def

@@ -314,4 +314,16 @@ PROCEDURE SetEndLocation (location: location_t) ;
 PROCEDURE BuildBuiltinCallTree (func: tree) : tree ;
 
 
+(*
+   CopyByField - copy expr to des, if des is a record, union or an array
+                 then check fields for GCC type equivalence and if necessary
+                 call __builtin_strncpy and __builtin_memcpy.
+                 This can occur if an expr contains a constant string
+                 which is to be assigned into a field declared as
+                 an ARRAY [0..n] OF CHAR.
+*)
+
+PROCEDURE CopyByField (location: location_t; des, expr: tree) ;
+
+
 END m2statement.

gcc/m2/gm2-gcc/m2statement.h

@@ -108,6 +108,7 @@ EXTERN tree m2statement_BuildBuiltinCallTree (tree func);
 EXTERN tree m2statement_BuildTryFinally (location_t location, tree call,
                                          tree cleanups);
 EXTERN tree m2statement_BuildCleanUp (tree param);
+EXTERN void m2statement_CopyByField (location_t location, tree des, tree expr);
 
 #undef EXTERN
 #endif /* m2statement_h.  */

gcc/m2/gm2-gcc/m2type.cc

@@ -3105,10 +3105,68 @@ m2type_gm2_signed_or_unsigned_type (int unsignedp, tree type)
 
 /* IsAddress returns true if the type is an ADDRESS.  */
 
-int
+bool
 m2type_IsAddress (tree type)
 {
   return type == ptr_type_node;
 }
 
+/* check_record_fields return true if all the fields in left and right
+   are GCC equivalent.  */
+
+static
+bool
+check_record_fields (tree left, tree right)
+{
+  unsigned int i;
+  tree right_value;
+  vec<constructor_elt, va_gc> *values = CONSTRUCTOR_ELTS (right);
+  FOR_EACH_CONSTRUCTOR_VALUE (values, i, right_value)
+    {
+      tree left_field = TREE_TYPE (m2treelib_get_field_no (left, NULL_TREE, false, i));
+      if (! m2type_IsGccStrictTypeEquivalent (left_field, right_value))
+	return false;
+    }
+  return true;
+}
+
+/* check_array_types return true if left and right have the same type and right
+   is not a CST_STRING.  */
+
+static
+bool
+check_array_types (tree right)
+{
+  unsigned int i;
+  tree value;
+  vec<constructor_elt, va_gc> *values = CONSTRUCTOR_ELTS (right);
+  FOR_EACH_CONSTRUCTOR_VALUE (values, i, value)
+    {
+      enum tree_code right_code = TREE_CODE (value);
+      if (right_code == STRING_CST)
+	return false;
+    }
+  return true;
+}
+
+bool
+m2type_IsGccStrictTypeEquivalent (tree left, tree right)
+{
+  enum tree_code right_code = TREE_CODE (right);
+  enum tree_code left_code = TREE_CODE (left);
+  if (left_code == VAR_DECL)
+    return m2type_IsGccStrictTypeEquivalent (TREE_TYPE (left), right);
+  if (right_code == VAR_DECL)
+    return m2type_IsGccStrictTypeEquivalent (left, TREE_TYPE (right));
+  if (left_code == RECORD_TYPE && right_code == CONSTRUCTOR)
+    return check_record_fields (left, right);
+  if (left_code == UNION_TYPE && right_code == CONSTRUCTOR)
+    return false;
+  if (left_code == ARRAY_TYPE && right_code == CONSTRUCTOR)
+    return check_array_types (right);
+  if (right_code == STRING_CST)
+    return false;
+  return true;
+}
+
 #include "gt-m2-m2type.h"

gcc/m2/gm2-gcc/m2type.def

@@ -996,4 +996,12 @@ PROCEDURE IsAddress (type: tree) : BOOLEAN ;
 PROCEDURE SameRealType (a, b: tree) : BOOLEAN ;
 
 
+(*
+   IsGccStrictTypeEquivalent - return true if left and right and
+                               all their contents have the same type.
+*)
+
+PROCEDURE IsGccStrictTypeEquivalent (left, right: tree) : BOOLEAN ;
+
+
 END m2type.

gcc/m2/gm2-gcc/m2type.h

@@ -210,10 +210,10 @@ EXTERN tree m2type_gm2_type_for_size (unsigned int bits, int unsignedp);
 EXTERN tree m2type_BuildProcTypeParameterDeclaration (location_t location,
                                                       tree type,
                                                       bool isreference);
-EXTERN int m2type_IsAddress (tree type);
+EXTERN bool m2type_IsAddress (tree type);
 EXTERN tree m2type_GetCardinalAddressType (void);
 EXTERN bool m2type_SameRealType (tree a, tree b);
-
+EXTERN bool m2type_IsGccStrictTypeEquivalent (tree left, tree right);
 
 #undef EXTERN
 #endif /* m2type_h  */