1 /* Simulate storage of variables into target memory.
2 Copyright (C) 2007-2024 Free Software Foundation, Inc.
3 Contributed by Paul Thomas and Brooks Moses
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
27 #include "fold-const.h"
28 #include "stor-layout.h"
30 #include "constructor.h"
31 #include "trans-const.h"
32 #include "trans-types.h"
33 #include "target-memory.h"
35 /* --------------------------------------------------------------- */
36 /* Calculate the size of an expression. */
40 size_integer (int kind
)
42 return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_int_type (kind
)));
49 return GET_MODE_SIZE (SCALAR_FLOAT_TYPE_MODE (gfc_get_real_type (kind
)));
54 size_complex (int kind
)
56 return 2 * size_float (kind
);
61 size_logical (int kind
)
63 return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_logical_type (kind
)));
68 size_character (gfc_charlen_t length
, int kind
)
70 int i
= gfc_validate_kind (BT_CHARACTER
, kind
, false);
71 return length
* gfc_character_kinds
[i
].bit_size
/ 8;
75 /* Return the size of a single element of the given expression.
76 Equivalent to gfc_target_expr_size for scalars. */
79 gfc_element_size (gfc_expr
*e
, size_t *siz
)
86 *siz
= size_integer (e
->ts
.kind
);
89 *siz
= size_float (e
->ts
.kind
);
92 *siz
= size_complex (e
->ts
.kind
);
95 *siz
= size_logical (e
->ts
.kind
);
98 if (e
->expr_type
== EXPR_CONSTANT
)
99 *siz
= size_character (e
->value
.character
.length
, e
->ts
.kind
);
100 else if (e
->ts
.u
.cl
!= NULL
&& e
->ts
.u
.cl
->length
!= NULL
101 && e
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
102 && e
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
)
104 HOST_WIDE_INT length
;
106 gfc_extract_hwi (e
->ts
.u
.cl
->length
, &length
);
107 *siz
= size_character (length
, e
->ts
.kind
);
117 *siz
= e
->representation
.length
;
125 /* Determine type size without clobbering the typespec for ISO C
130 type
= gfc_typenode_for_spec (&ts
);
131 size
= int_size_in_bytes (type
);
132 gcc_assert (size
>= 0);
137 gfc_internal_error ("Invalid expression in gfc_element_size.");
144 /* Return the size of an expression in its target representation. */
147 gfc_target_expr_size (gfc_expr
*e
, size_t *size
)
152 gcc_assert (e
!= NULL
);
157 if (gfc_array_size (e
, &tmp
))
158 asz
= mpz_get_ui (tmp
);
165 if (!gfc_element_size (e
, &el_size
))
167 *size
= asz
* el_size
;
172 /* The encode_* functions export a value into a buffer, and
173 return the number of bytes of the buffer that have been
176 static unsigned HOST_WIDE_INT
177 encode_array (gfc_expr
*expr
, unsigned char *buffer
, size_t buffer_size
)
183 gfc_constructor_base ctor
= expr
->value
.constructor
;
185 gfc_array_size (expr
, &array_size
);
186 for (i
= 0; i
< (int)mpz_get_ui (array_size
); i
++)
188 ptr
+= gfc_target_encode_expr (gfc_constructor_lookup_expr (ctor
, i
),
189 &buffer
[ptr
], buffer_size
- ptr
);
192 mpz_clear (array_size
);
198 encode_integer (int kind
, mpz_t integer
, unsigned char *buffer
,
201 return native_encode_expr (gfc_conv_mpz_to_tree (integer
, kind
),
202 buffer
, buffer_size
);
207 encode_float (int kind
, mpfr_t real
, unsigned char *buffer
, size_t buffer_size
)
209 return native_encode_expr (gfc_conv_mpfr_to_tree (real
, kind
, 0), buffer
,
215 encode_complex (int kind
, mpc_t cmplx
,
216 unsigned char *buffer
, size_t buffer_size
)
219 size
= encode_float (kind
, mpc_realref (cmplx
), &buffer
[0], buffer_size
);
220 size
+= encode_float (kind
, mpc_imagref (cmplx
),
221 &buffer
[size
], buffer_size
- size
);
227 encode_logical (int kind
, int logical
, unsigned char *buffer
, size_t buffer_size
)
229 return native_encode_expr (build_int_cst (gfc_get_logical_type (kind
),
231 buffer
, buffer_size
);
236 gfc_encode_character (int kind
, size_t length
, const gfc_char_t
*string
,
237 unsigned char *buffer
, size_t buffer_size
)
239 size_t elsize
= size_character (1, kind
);
240 tree type
= gfc_get_char_type (kind
);
242 gcc_assert (buffer_size
>= size_character (length
, kind
));
244 for (size_t i
= 0; i
< length
; i
++)
245 native_encode_expr (build_int_cst (type
, string
[i
]), &buffer
[i
*elsize
],
252 static unsigned HOST_WIDE_INT
253 encode_derived (gfc_expr
*source
, unsigned char *buffer
, size_t buffer_size
)
261 type
= gfc_typenode_for_spec (&source
->ts
);
263 for (c
= gfc_constructor_first (source
->value
.constructor
),
264 cmp
= source
->ts
.u
.derived
->components
;
266 c
= gfc_constructor_next (c
), cmp
= cmp
->next
)
271 ptr
= TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp
->backend_decl
))
272 + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp
->backend_decl
))/8;
274 if (c
->expr
->expr_type
== EXPR_NULL
)
276 size
= int_size_in_bytes (TREE_TYPE (cmp
->backend_decl
));
277 gcc_assert (size
>= 0);
278 memset (&buffer
[ptr
], 0, size
);
281 gfc_target_encode_expr (c
->expr
, &buffer
[ptr
],
285 size
= int_size_in_bytes (type
);
286 gcc_assert (size
>= 0);
291 /* Write a constant expression in binary form to a buffer. */
292 unsigned HOST_WIDE_INT
293 gfc_target_encode_expr (gfc_expr
*source
, unsigned char *buffer
,
299 if (source
->expr_type
== EXPR_ARRAY
)
300 return encode_array (source
, buffer
, buffer_size
);
302 gcc_assert (source
->expr_type
== EXPR_CONSTANT
303 || source
->expr_type
== EXPR_STRUCTURE
304 || source
->expr_type
== EXPR_SUBSTRING
);
306 /* If we already have a target-memory representation, we use that rather
307 than recreating one. */
308 if (source
->representation
.string
)
310 memcpy (buffer
, source
->representation
.string
,
311 source
->representation
.length
);
312 return source
->representation
.length
;
315 switch (source
->ts
.type
)
318 return encode_integer (source
->ts
.kind
, source
->value
.integer
, buffer
,
321 return encode_float (source
->ts
.kind
, source
->value
.real
, buffer
,
324 return encode_complex (source
->ts
.kind
, source
->value
.complex,
325 buffer
, buffer_size
);
327 return encode_logical (source
->ts
.kind
, source
->value
.logical
, buffer
,
330 if (source
->expr_type
== EXPR_CONSTANT
|| source
->ref
== NULL
)
331 return gfc_encode_character (source
->ts
.kind
,
332 source
->value
.character
.length
,
333 source
->value
.character
.string
,
334 buffer
, buffer_size
);
337 HOST_WIDE_INT start
, end
;
339 gcc_assert (source
->expr_type
== EXPR_SUBSTRING
);
340 gfc_extract_hwi (source
->ref
->u
.ss
.start
, &start
);
341 gfc_extract_hwi (source
->ref
->u
.ss
.end
, &end
);
342 return gfc_encode_character (source
->ts
.kind
, MAX(end
- start
+ 1, 0),
343 &source
->value
.character
.string
[start
-1],
344 buffer
, buffer_size
);
348 if (source
->ts
.u
.derived
->ts
.f90_type
== BT_VOID
)
351 gcc_assert (source
->expr_type
== EXPR_STRUCTURE
);
352 c
= gfc_constructor_first (source
->value
.constructor
);
353 gcc_assert (c
->expr
->expr_type
== EXPR_CONSTANT
354 && c
->expr
->ts
.type
== BT_INTEGER
);
355 return encode_integer (gfc_index_integer_kind
, c
->expr
->value
.integer
,
356 buffer
, buffer_size
);
359 return encode_derived (source
, buffer
, buffer_size
);
361 gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
368 interpret_array (unsigned char *buffer
, size_t buffer_size
, gfc_expr
*result
,
369 bool convert_widechar
)
371 gfc_constructor_base base
= NULL
;
372 size_t array_size
= 1;
375 /* Calculate array size from its shape and rank. */
376 gcc_assert (result
->rank
> 0 && result
->shape
);
378 for (int i
= 0; i
< result
->rank
; i
++)
379 array_size
*= mpz_get_ui (result
->shape
[i
]);
381 /* Iterate over array elements, producing constructors. */
382 for (size_t i
= 0; i
< array_size
; i
++)
384 gfc_expr
*e
= gfc_get_constant_expr (result
->ts
.type
, result
->ts
.kind
,
388 if (e
->ts
.type
== BT_CHARACTER
)
389 e
->value
.character
.length
= result
->value
.character
.length
;
391 gfc_constructor_append_expr (&base
, e
, &result
->where
);
393 ptr
+= gfc_target_interpret_expr (&buffer
[ptr
], buffer_size
- ptr
, e
,
397 result
->value
.constructor
= base
;
403 gfc_interpret_integer (int kind
, unsigned char *buffer
, size_t buffer_size
,
407 gfc_conv_tree_to_mpz (integer
,
408 native_interpret_expr (gfc_get_int_type (kind
),
409 buffer
, buffer_size
));
410 return size_integer (kind
);
415 gfc_interpret_float (int kind
, unsigned char *buffer
, size_t buffer_size
,
418 gfc_set_model_kind (kind
);
420 tree source
= native_interpret_expr (gfc_get_real_type (kind
), buffer
,
426 gfc_conv_tree_to_mpfr (real
, source
);
427 return size_float (kind
);
432 gfc_interpret_complex (int kind
, unsigned char *buffer
, size_t buffer_size
,
436 size
= gfc_interpret_float (kind
, &buffer
[0], buffer_size
,
437 mpc_realref (complex));
438 size
+= gfc_interpret_float (kind
, &buffer
[size
], buffer_size
- size
,
439 mpc_imagref (complex));
445 gfc_interpret_logical (int kind
, unsigned char *buffer
, size_t buffer_size
,
448 tree t
= native_interpret_expr (gfc_get_logical_type (kind
), buffer
,
450 *logical
= wi::to_wide (t
) == 0 ? 0 : 1;
451 return size_logical (kind
);
456 gfc_interpret_character (unsigned char *buffer
, size_t buffer_size
,
459 if (result
->ts
.u
.cl
&& result
->ts
.u
.cl
->length
)
460 result
->value
.character
.length
=
461 gfc_mpz_get_hwi (result
->ts
.u
.cl
->length
->value
.integer
);
463 gcc_assert (buffer_size
>= size_character (result
->value
.character
.length
,
465 result
->value
.character
.string
=
466 gfc_get_wide_string (result
->value
.character
.length
+ 1);
468 if (result
->ts
.kind
== gfc_default_character_kind
)
469 for (size_t i
= 0; i
< (size_t) result
->value
.character
.length
; i
++)
470 result
->value
.character
.string
[i
] = (gfc_char_t
) buffer
[i
];
474 size_t bytes
= size_character (1, result
->ts
.kind
);
476 gcc_assert (bytes
<= sizeof (unsigned long));
478 for (size_t i
= 0; i
< (size_t) result
->value
.character
.length
; i
++)
480 gfc_conv_tree_to_mpz (integer
,
481 native_interpret_expr (gfc_get_char_type (result
->ts
.kind
),
482 &buffer
[bytes
*i
], buffer_size
-bytes
*i
));
483 result
->value
.character
.string
[i
]
484 = (gfc_char_t
) mpz_get_ui (integer
);
490 result
->value
.character
.string
[result
->value
.character
.length
] = '\0';
492 return size_character (result
->value
.character
.length
, result
->ts
.kind
);
497 gfc_interpret_derived (unsigned char *buffer
, size_t buffer_size
, gfc_expr
*result
)
503 /* The attributes of the derived type need to be bolted to the floor. */
504 result
->expr_type
= EXPR_STRUCTURE
;
506 cmp
= result
->ts
.u
.derived
->components
;
508 if (result
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
509 && (result
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_PTR
510 || result
->ts
.u
.derived
->intmod_sym_id
== ISOCBINDING_FUNPTR
))
514 /* Needed as gfc_typenode_for_spec as gfc_typenode_for_spec
515 sets this to BT_INTEGER. */
516 result
->ts
.type
= BT_DERIVED
;
517 e
= gfc_get_constant_expr (cmp
->ts
.type
, cmp
->ts
.kind
, &result
->where
);
518 c
= gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
519 c
->n
.component
= cmp
;
520 gfc_target_interpret_expr (buffer
, buffer_size
, e
, true);
522 return int_size_in_bytes (ptr_type_node
);
525 type
= gfc_typenode_for_spec (&result
->ts
);
527 /* Run through the derived type components. */
528 for (;cmp
; cmp
= cmp
->next
)
531 gfc_expr
*e
= gfc_get_constant_expr (cmp
->ts
.type
, cmp
->ts
.kind
,
535 /* Copy shape, if needed. */
536 if (cmp
->as
&& cmp
->as
->rank
)
540 if (cmp
->as
->type
!= AS_EXPLICIT
)
543 e
->expr_type
= EXPR_ARRAY
;
544 e
->rank
= cmp
->as
->rank
;
546 e
->shape
= gfc_get_shape (e
->rank
);
547 for (n
= 0; n
< e
->rank
; n
++)
549 mpz_init_set_ui (e
->shape
[n
], 1);
550 mpz_add (e
->shape
[n
], e
->shape
[n
],
551 cmp
->as
->upper
[n
]->value
.integer
);
552 mpz_sub (e
->shape
[n
], e
->shape
[n
],
553 cmp
->as
->lower
[n
]->value
.integer
);
557 c
= gfc_constructor_append_expr (&result
->value
.constructor
, e
, NULL
);
559 /* The constructor points to the component. */
560 c
->n
.component
= cmp
;
562 /* Calculate the offset, which consists of the FIELD_OFFSET in
563 bytes, which appears in multiples of DECL_OFFSET_ALIGN-bit-sized,
564 and additional bits of FIELD_BIT_OFFSET. The code assumes that all
565 sizes of the components are multiples of BITS_PER_UNIT,
566 i.e. there are, e.g., no bit fields. */
568 gcc_assert (cmp
->backend_decl
);
569 ptr
= TREE_INT_CST_LOW (DECL_FIELD_BIT_OFFSET (cmp
->backend_decl
));
570 gcc_assert (ptr
% 8 == 0);
571 ptr
= ptr
/8 + TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp
->backend_decl
));
573 gcc_assert (e
->ts
.type
!= BT_VOID
|| cmp
->attr
.caf_token
);
574 gfc_target_interpret_expr (&buffer
[ptr
], buffer_size
- ptr
, e
, true);
577 return int_size_in_bytes (type
);
581 /* Read a binary buffer to a constant expression. */
583 gfc_target_interpret_expr (unsigned char *buffer
, size_t buffer_size
,
584 gfc_expr
*result
, bool convert_widechar
)
586 if (result
->expr_type
== EXPR_ARRAY
)
587 return interpret_array (buffer
, buffer_size
, result
, convert_widechar
);
589 switch (result
->ts
.type
)
592 result
->representation
.length
=
593 gfc_interpret_integer (result
->ts
.kind
, buffer
, buffer_size
,
594 result
->value
.integer
);
598 result
->representation
.length
=
599 gfc_interpret_float (result
->ts
.kind
, buffer
, buffer_size
,
604 result
->representation
.length
=
605 gfc_interpret_complex (result
->ts
.kind
, buffer
, buffer_size
,
606 result
->value
.complex);
610 result
->representation
.length
=
611 gfc_interpret_logical (result
->ts
.kind
, buffer
, buffer_size
,
612 &result
->value
.logical
);
616 result
->representation
.length
=
617 gfc_interpret_character (buffer
, buffer_size
, result
);
621 result
->ts
= CLASS_DATA (result
)->ts
;
624 result
->representation
.length
=
625 gfc_interpret_derived (buffer
, buffer_size
, result
);
626 gcc_assert (result
->representation
.length
>= 0);
630 /* This deals with caf_tokens. */
631 result
->representation
.length
=
632 gfc_interpret_integer (result
->ts
.kind
, buffer
, buffer_size
,
633 result
->value
.integer
);
637 gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
641 if (result
->ts
.type
== BT_CHARACTER
&& convert_widechar
)
642 result
->representation
.string
643 = gfc_widechar_to_char (result
->value
.character
.string
,
644 result
->value
.character
.length
);
647 result
->representation
.string
=
648 XCNEWVEC (char, result
->representation
.length
+ 1);
649 memcpy (result
->representation
.string
, buffer
,
650 result
->representation
.length
);
651 result
->representation
.string
[result
->representation
.length
] = '\0';
654 return result
->representation
.length
;
658 /* --------------------------------------------------------------- */
659 /* Two functions used by trans-common.cc to write overlapping
660 equivalence initializers to a buffer. This is added to the union
661 and the original initializers freed. */
664 /* Writes the values of a constant expression to a char buffer. If another
665 unequal initializer has already been written to the buffer, this is an
669 expr_to_char (gfc_expr
*e
, locus
*loc
,
670 unsigned char *data
, unsigned char *chk
, size_t len
)
676 unsigned char *buffer
;
681 /* Take a derived type, one component at a time, using the offsets from the backend
683 if (e
->ts
.type
== BT_DERIVED
)
685 for (c
= gfc_constructor_first (e
->value
.constructor
),
686 cmp
= e
->ts
.u
.derived
->components
;
687 c
; c
= gfc_constructor_next (c
), cmp
= cmp
->next
)
689 gcc_assert (cmp
&& cmp
->backend_decl
);
692 ptr
= TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp
->backend_decl
))
693 + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp
->backend_decl
))/8;
694 expr_to_char (c
->expr
, loc
, &data
[ptr
], &chk
[ptr
], len
);
699 /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate
700 to the target, in a buffer and check off the initialized part of the buffer. */
701 gfc_target_expr_size (e
, &len
);
702 buffer
= (unsigned char*)alloca (len
);
703 len
= gfc_target_encode_expr (e
, buffer
, len
);
705 for (i
= 0; i
< (int)len
; i
++)
707 if (chk
[i
] && (buffer
[i
] != data
[i
]))
710 gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
713 gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
720 memcpy (data
, buffer
, len
);
725 /* Writes the values from the equivalence initializers to a char* array
726 that will be written to the constructor to make the initializer for
727 the union declaration. */
730 gfc_merge_initializers (gfc_typespec ts
, gfc_expr
*e
, locus
*loc
,
732 unsigned char *chk
, size_t length
)
737 switch (e
->expr_type
)
741 len
= expr_to_char (e
, loc
, &data
[0], &chk
[0], length
);
745 for (c
= gfc_constructor_first (e
->value
.constructor
);
746 c
; c
= gfc_constructor_next (c
))
750 gfc_target_expr_size (c
->expr
, &elt_size
);
752 if (mpz_cmp_si (c
->offset
, 0) != 0)
753 len
= elt_size
* (size_t)mpz_get_si (c
->offset
);
755 len
= len
+ gfc_merge_initializers (ts
, c
->expr
, loc
, &data
[len
],
756 &chk
[len
], length
- len
);
768 /* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
769 When successful, no BOZ or nothing to do, true is returned. */
772 gfc_convert_boz (gfc_expr
*expr
, gfc_typespec
*ts
)
774 size_t buffer_size
, boz_bit_size
, ts_bit_size
;
776 unsigned char *buffer
;
778 if (expr
->ts
.type
!= BT_INTEGER
)
781 /* Don't convert BOZ to logical, character, derived etc. */
782 gcc_assert (ts
->type
== BT_REAL
);
784 buffer_size
= size_float (ts
->kind
);
785 ts_bit_size
= buffer_size
* 8;
787 /* Convert BOZ to the smallest possible integer kind. */
788 boz_bit_size
= mpz_sizeinbase (expr
->value
.integer
, 2);
790 gcc_assert (boz_bit_size
<= ts_bit_size
);
792 for (index
= 0; gfc_integer_kinds
[index
].kind
!= 0; ++index
)
793 if ((unsigned) gfc_integer_kinds
[index
].bit_size
>= ts_bit_size
)
796 expr
->ts
.kind
= gfc_integer_kinds
[index
].kind
;
797 buffer_size
= MAX (buffer_size
, size_integer (expr
->ts
.kind
));
799 buffer
= (unsigned char*)alloca (buffer_size
);
800 encode_integer (expr
->ts
.kind
, expr
->value
.integer
, buffer
, buffer_size
);
801 mpz_clear (expr
->value
.integer
);
803 mpfr_init (expr
->value
.real
);
804 gfc_interpret_float (ts
->kind
, buffer
, buffer_size
, expr
->value
.real
);
806 expr
->ts
.type
= ts
->type
;
807 expr
->ts
.kind
= ts
->kind
;